diff options
Diffstat (limited to 'src/interp/g-util.boot')
| -rw-r--r-- | src/interp/g-util.boot | 563 |
1 files changed, 0 insertions, 563 deletions
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 355a78ff..9ea6cca1 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -43,7 +43,6 @@ module g_-util where pairList: (%List,%List) -> %List mkList: %List -> %List isSubDomain: (%Mode,%Mode) -> %Form - expandToVMForm: %Thing -> %Thing usedSymbol?: (%Symbol,%Code) -> %Boolean isDefaultPackageName: %Symbol -> %Boolean @@ -121,568 +120,6 @@ mkVMForm(op,args) == arg is ['%not,arg'] => arg' ['%not,:args] ---% ---% Opcode expansion to VM codes. ---% - - ---% ---% Iteration control structures ---% ---% Code generation for an iterator produces a sequence of ---% length 5, whose components have the following meanings: ---% 0. list of loop-wide variables and their initializers ---% 1. list of body-wide variables and their initializers ---% 2. update code for next iteration ---% 3. predicate guarding loop body execution ---% 4. loop termination predicate - -++ Generate code that sequentially visits each component of a list. -expandIN(x,l,early?) == - g := gensym() -- rest of the list yet to be visited - early? => -- give the loop variable a wider scope. - [[[g,middleEndExpand l],[x,'NIL]], - nil,[['SETQ,g,['CDR,g]]], - nil,[['ATOM,g],['PROGN,['SETQ,x,['CAR,g]],'NIL]]] - [[[g,middleEndExpand l]], - [[x,['CAR,g]]],[['SETQ,g,['CDR,g]]], - nil,[['ATOM,g]]] - -expandON(x,l) == - [[[x,middleEndExpand l]],nil,[["SETQ",x,["CDR",x]]],nil,[["ATOM",x]]] - -++ Generate code that traverses an interval with lower bound 'lo', -++ arithmetic progression `step, and possible upper bound `final'. -expandSTEP(id,lo,step,final)== - lo := middleEndExpand lo - step := middleEndExpand step - final := middleEndExpand final - loopvar := [[id,lo]] - inc := - atomic? step => step - g1 := gensym() - loopvar := [:loopvar,[g1,step]] - g1 - final := - atom final => final - final is [hi] and atomic? hi => hi - g2 := gensym() - loopvar := [:loopvar,[g2,:final]] - g2 - ex := - final = nil => nil - integer? inc => - pred := - MINUSP inc => "<" - ">" - [[pred,id,final]] - [['COND,[['MINUSP,inc], - ["<",id,final]],['T,[">",id,final]]]] - suc := [["SETQ",id,["+",id,inc]]] - [loopvar,nil,suc,nil,ex] - -++ Generate code for iterators that filter out execution state -++ not satisfying predicate `p'. -expandSUCHTHAT p == - [nil,nil,nil,[middleEndExpand p],nil] - -++ Generate code for iterators that stop loop iteration when the -++ state fails predicate `p'. -expandWHILE p == - [nil,nil,nil,nil,[["NOT",middleEndExpand p]]] - -expandUNTIL p == - g := gensym() - [[[g,false]],nil,[["SETQ",g,middleEndExpand p]],nil,[g]] - -expandInit(var,val) == - [[[var,middleEndExpand val]],nil,nil,nil,nil] - -expandIterators iters == - -- Exit predicates may reference iterator variables. In that case, - -- the scope the variables must cover the generated loop body. The - -- following is much more coarse approximation than we may want, - -- but it will do. For now. - early? := or/[ it.op in '(WHILE UNTIL) for it in iters] - [toLisp(it,early?) or leave "failed" for it in iters] where - toLisp(it,early?) == - it is ["STEP",var,lo,inc,:hi] => expandSTEP(var,lo,inc,hi) - it is ["IN",var,seq] => expandIN(var,seq,early?) - it is ["ON",var,seq] => expandON(var,seq) - it is ["WHILE",pred] => expandWHILE pred - it is [op,pred] and op in '(SUCHTHAT _|) => expandSUCHTHAT pred - it is ["UNTIL",pred] => expandUNTIL pred - it is ["%init",var,val] => expandInit(var,val) - nil - -expandLoop ['%loop,:iters,body,ret] == - itersCode := expandIterators iters - itersCode = "failed" => systemErrorHere ["expandLoop",iters] - body := middleEndExpand body - itersCode := "coagulate"/itersCode - where - coagulate(it1,it2) == [append(it1.k,it2.k) for k in 0..4] - [loopInits,bodyInits,cont,filters,exits] := itersCode - -- Guard the execution of the body by the filters. - if filters ~= nil then - body := mkpf([:filters,body],"AND") - -- If there is any body-wide initialization, now is the time. - if bodyInits ~= nil then - body := ["LET",bodyInits,body] - exits := ["COND", - [mkpf(exits,"OR"),["RETURN",expandToVMForm ret]], - [true,body]] - body := ["LOOP",exits,:cont] - -- Finally, set up loop-wide initializations. - loopInits = nil => body - ["LET",loopInits,body] - -++ Generate code for list comprehension. -expandCollect ['%collect,:iters,body] == - val := gensym() -- result of the list comprehension - -- Transform the body to build the list as we go. - body := ["SETQ",val,["CONS",middleEndExpand body,val]] - -- Initialize the variable holding the result; expand as - -- if ordinary loop. But don't forget we built the result - -- in reverse order. - expandLoop ['%loop,:iters,["%init",val,nil],body,["NREVERSE",val]] - -expandListlit(x is ['%listlit,:args]) == - args := [expandToVMForm arg for arg in args] - args = nil => nil - args' := [simpleValue? arg or leave 'failed for arg in args] - where simpleValue? arg == - integer? arg or string? arg => arg - arg is ['QUOTE,form] => form - nil - args' = 'failed => ['LIST,:args] - quoteForm args' - -expandReturn(x is ['%return,.,y]) == - $FUNNAME = nil => systemErrorHere ['expandReturn,x] - ['RETURN_-FROM,$FUNNAME,expandToVMForm y] - --- Pointer operations -expandPeq ['%peq,x,y] == - x = '%nil => ['NULL,expandToVMForm y] - y = '%nil => ['NULL,expandToVMForm x] - ['EQ,expandToVMForm x, expandToVMForm y] - -expandBefore? ['%before?,x,y] == - ['GGREATERP,expandToVMForm y,expandToVMForm x] - --- Byte operations -expandBcompl ['%bcompl,x] == - integer? x => 255 - x - ['_+,256,['LOGNOT,expandToVMForm x]] - --- Character operations -expandCcst ['%ccst,s] == - -- FIXME: this expander should return forms, instead of character constants - not string? s => error "operand is not a string constant" - stringToChar s - -++ string-to-character conversion. -expandS2c ['%s2c, x] == - string? x => expandCcst ['%ccst, x] - ['stringToChar, x] - --- Integer operations -expandIneg ['%ineg,x] == - x := expandToVMForm x - integer? x => -x - ['_-,x] - -expandIdivide ['%idivide,x,y] == - ['MULTIPLE_-VALUE_-CALL,['FUNCTION,'CONS], - ['TRUNCATE,expandToVMForm x,expandToVMForm y]] - -expandIeq ['%ieq,a,b] == - a := expandToVMForm a - integer? a and a = 0 => ['ZEROP,expandToVMForm b] - b := expandToVMForm b - integer? b and b = 0 => ['ZEROP,a] - ['EQL,a,b] - -expandIlt ['%ilt,x,y] == - integer? x and x = 0 => - integer? y => y > 0 - ['PLUSP,expandToVMForm y] - integer? y and y = 0 => - integer? x => x < 0 - ['MINUSP,expandToVMForm x] - ['_<,expandToVMForm x,expandToVMForm y] - -expandIgt ['%igt,x,y] == - expandIlt ['%ilt,y,x] - -expandBitand ['%bitand,x,y] == - ['BOOLE,'BOOLE_-AND,expandToVMForm x,expandToVMForm y] - -expandBitior ['%bitior,x,y] == - ['BOOLE,'BOOLE_-IOR,expandToVMForm x,expandToVMForm y] - -expandBitnot ['%bitnot,x] == - ['LOGNOT,expandToVMForm x] - --- Floating point support - -expandFbase ['%fbase] == - FLOAT_-RADIX $DoubleFloatMaximum - -expandFprec ['%fprec] == - FLOAT_-DIGITS $DoubleFloatMaximum - -expandFminval ['%fminval] == - '$DoubleFloatMinimum - -expandFmaxval ['%fmaxval] == - '$DoubleFloatMaximum - -expandI2f ['%i2f,x] == - x := expandToVMForm x - integer? x and (x = 0 or x = 1) => FLOAT(x,$DoubleFloatMaximum) - ['FLOAT,x,'$DoubleFloatMaximum] - -expandFneg ['%fneg,x] == - ['_-,expandToVMForm x] - -expandFeq ['%feq,a,b] == - a is ['%i2f,0] => ['ZEROP,expandToVMForm b] - b is ['%i2f,0] => ['ZEROP,expandToVMForm a] - ['_=,expandToVMForm a,expandToVMForm b] - -expandFlt ['%flt,x,y] == - x is ['%i2f,0] => ['PLUSP,expandToVMForm y] - y is ['%i2f,0] => ['MINUSP,expandToVMForm x] - ['_<,expandToVMForm x,expandToVMForm y] - -expandFgt ['%fgt,x,y] == - expandFlt ['%flt,y,x] - -expandFcstpi ['%fcstpi] == - ['COERCE,'PI,quoteForm '%DoubleFloat] - --- String operations - -++ string equality comparison -expandStreq ['%streq,x,y] == - expandToVMForm ['%not,['%peq,['STRING_=,x,y],'%nil]] - -++ string lexicographic comparison -expandStrlt ['%strlt,x,y] == - expandToVMForm ['%not,['%peq,['STRING_<,x,y],'%nil]] - -++ deposit a character `z' at slot number `y' in string object `x'. -expandStrstc ['%strstc,x,y,z] == - expandToVMForm ['%store,['%schar,x,y],z] - --- bit vector operations -expandBitvecnot ['%bitvecnot,x] == - ['BIT_-NOT,expandToVMForm x] - -expandBitvecand ['%bitvecand,x,y] == - ['BIT_-AND,expandToVMForm x,expandToVMForm y] - -expandBitvecnand ['%bitvecnand,x,y] == - ['BIT_-NAND,expandToVMForm x,expandToVMForm y] - -expandBitvecor ['%bitvecor,x,y] == - ['BIT_-IOR,expandToVMForm x,expandToVMForm y] - -expandBitvecnor ['%bitvecnor,x,y] == - ['BIT_-NOR,expandToVMForm x,expandToVMForm y] - -expandBitvecxor ['%bitvecxor,x,y] == - ['BIT_-XOR,expandToVMForm x,expandToVMForm y] - -expandBitveclength ['%bitveclength,x] == - ['LENGTH,expandToVMForm x] - -expandBitveccopy ['%bitveccopy,x] == - ['COPY_-SEQ,expandToVMForm x] - -expandBitvecconc ['%bitvecconc,x,y] == - ['CONCATENATE, quoteForm '%BitVector,expandToVMForm x,expandToVMForm y] - -expandBitvecref ['%bitvecref,x,y] == - ['SBIT,expandToVMForm x,expandToVMForm y] - -expandBitveceq ['%bitveceq,x,y] == - ['EQUAL,expandToVMForm x,expandToVMForm y] - -expandMakebitvec ['%makebitvec,x,y] == - ['MAKE_-ARRAY,['LIST,expandToVMForm x], - KEYWORD::ELEMENT_-TYPE,quoteForm '%Bit, - KEYWORD::INITIAL_-ELEMENT,expandToVMForm y] - --- Local variable bindings -expandBind ['%bind,inits,:body] == - body := expandToVMForm body - inits := [[first x,expandToVMForm second x] for x in inits] - -- FIXME: we should consider turning LET* into LET or direct inlining. - op := - or/[CONTAINED(v,x) for [[v,.],:x] in tails inits] => 'LET_* - 'LET - [op,inits,:body] - --- Memory load/store - -expandDynval ["%dynval",:args] == - ["SYMBOL-VALUE",:expandToVMForm args] - -expandStore ["%store",place,value] == - value := expandToVMForm value - place is ['%head,x] => ['RPLACA,expandToVMForm x,value] - place is ['%tail,x] => ['RPLACD,expandToVMForm x,value] - place := expandToVMForm place - cons? place => ["SETF",place,value] - ["SETQ",place,value] - --- non-local control transfer - -$OpenAxiomCatchTag == KEYWORD::OpenAxiomCatchPoint - -expandThrow ['%throw,m,x] == - ['THROW,$OpenAxiomCatchTag, - ['CONS,$OpenAxiomCatchTag, - ['CONS,expandToVMForm m,expandToVMForm x]]] - -++ Subroutine of expandTry. Generate code for domain matching -++ of object `obj' with domain `dom'. -domainMatchCode(dom,obj) == - -- FIXME: Instead of domain equality, we should also consider - -- FIXME: cases of sub-domains, or domain schemes with constraints. - ['domainEqual,dom,['%head,obj]] - -expandTry ['%try,expr,handlers,cleanup] == - g := gensym() -- hold the exception object - ys := [[domainMatchCode(mode,['%tail,g]), - ['%bind,[[var,['%tail,['%tail,g]]]],stmt]] - for [.,var,mode,stmt] in handlers] - handlerBody := - ys = nil => g - ys := [:ys,['%true,['THROW,$OpenAxiomCatchTag,g]]] - ['%when, - [['%and,['%pair?,g], - ['%peq,['%head,g],$OpenAxiomCatchTag]], ['%when,:ys]], - ['%true,g]] - tryBlock := expandBind - ['%bind,[[g,['CATCH,$OpenAxiomCatchTag,expr]]],handlerBody] - cleanup = nil => tryBlock - ['UNWIND_-PROTECT,tryBlock,:expandToVMForm rest cleanup] - -++ Opcodes with direct mapping to target operations. -for x in [ - -- Boolean constants - -- ['%false, :'NIL], - ['%true, :'T], - -- unary Boolean operations - ['%not, :'NOT], - ['%2bit, :'TRUTH_-TO_-BIT], - ['%2bool, :'BIT_-TO_-TRUTH], - -- binary Boolean operations - ['%and, :'AND], - ['%or, :'OR], - - -- character operations - ['%ceq, :'CHAR_=], - ['%clt, :'CHAR_<], - ['%cle, :'CHAR_<_=], - ['%cgt, :'CHAR_>], - ['%cge, :'CHAR_>_=], - ['%cup, :'CHAR_-UPCASE], - ['%cdown, :'CHAR_-DOWNCASE], - ['%c2i, :'CHAR_-CODE], - ['%i2c, :'CODE_-CHAR], - - -- byte operations - ['%beq, :'byteEqual], - ['%blt, :'byteLessThan], - - -- unary integer operations. - ['%iabs, :'ABS], - ['%ieven?, :'EVENP], - ['%integer?,:'INTEGERP], - ['%iodd?, :'ODDP], - ['%ismall?, :'FIXNUMP], - ['%i2s, :'WRITE_-TO_-STRING], - ['%ilength, :'INTEGER_-LENGTH], - ['%ibit, :'INTEGER_-BIT], - -- binary integer operations. - ['%iadd, :"+"], - ['%igcd, :'GCD], - ['%ige, :">="], - ['%iinc, :"1+"], - ['%idec, :"1-"], - ['%ilcm, :'LCM], - ['%ile, :"<="], - ['%imax, :'MAX], - ['%imin, :'MIN], - ['%imul, :"*"], - ['%irem, :'REM], - ['%iquo, :'TRUNCATE], - ['%ipow, :'EXPT], - ['%isub, :"-"], - - -- unary float operations. - ['%fabs, :'ABS], - ['%float?,:'FLOATP], - ['%ftrunc,:'TRUNCATE], - -- binary float operations. - ['%fadd, :"+"], - ['%fdiv, :"/"], - ['%fge, :">="], - ['%fle, :"<="], - ['%fmax, :'MAX], - ['%fmin, :'MIN], - ['%fmul, :"*"], - ['%fpow, :'EXPT], - ['%fsub, :"-"], - - ['%fsin, :'SIN], - ['%fcos, :'COS], - ['%ftan, :'TAN], - ['%fcot, :'COT], - ['%fsec, :'SEC], - ['%fcsc, :'CSC], - ['%fatan, :'ATAN], - ['%facot, :'ACOT], - ['%fsinh, :'SINH], - ['%fcosh, :'COSH], - ['%ftanh, :'TANH], - ['%fcsch, :'CSCH], - ['%fcoth, :'COTH], - ['%fsech, :'SECH], - ['%fasinh, :'ASINH], - ['%facsch, :'ACSCH], - - -- string operations - ['%f2s, :'DFLOAT_-FORMAT_-GENERAL], - - -- list contants - -- ['%nil, :'NIL], - -- unary list operations - ['%head, :'CAR], - ['%makepair, :'CONS], - ['%lempty?, :'NULL], - ['%lfirst, :'CAR], - ['%llength, :'LIST_-LENGTH], - ['%lreverse, :'REVERSE], - ['%lreverse_!,:'NREVERSE], - ['%lsecond, :'CADR], - ['%lthird, :'CADDR], - ['%pair?, :'CONSP], - ['%tail, :'CDR], - -- binary list operations - ['%lconcat, :'APPEND], - - -- simple vector operations - ['%vfill, :'FILL], - ['%vlength, :'sizeOfSimpleArray], - ['%veclit, :'VECTOR], - ['%vref, :'SVREF], - ['%aref, :'getSimpleArrayEntry], - ['%makevector,:'MAKE_-ARRAY], - - -- symbol unary functions - ['%gensym, :'GENSYM], - ['%sname, :'SYMBOL_-NAME], - ['%ident?, :'SYMBOLP], - - -- string functions - ['%string?, :'STRINGP], - ['%strlength, :'LENGTH], - ['%schar, :'CHAR], - ['%strconc, :'STRCONC], - ['%strcopy, :'COPY_-SEQ], - - -- general utility - ['%hash, :'SXHASH], - ['%equal, :'EQUAL], - ['%sptreq, :'EQL], -- system pointer equality - ['%lam, :'LAMBDA], - ['%leave, :'RETURN], - ['%otherwise,:'T], - ['%when, :'COND] - ] repeat property(first x,'%Rename) := rest x - -++ Table of opcode-expander pairs. -for x in [ - ['%listlit, :function expandListlit], - ['%collect, :function expandCollect], - ['%loop, :function expandLoop], - ['%return, :function expandReturn], - - ['%bcompl, :function expandBcompl], - - ['%ccst, :function expandCcst], - ['%s2c, :function expandS2c], - - ['%ieq, :function expandIeq], - ['%igt, :function expandIgt], - ['%ilt, :function expandIlt], - ['%ineg, :function expandIneg], - ['%idivide, :function expandIdivide], - ['%bitand, :function expandBitand], - ['%bitior, :function expandBitior], - ['%bitnot, :function expandBitnot], - - ['%i2f, :function expandI2f], - ['%fbase, :function expandFbase], - ['%feq, :function expandFeq], - ['%fgt, :function expandFgt], - ['%flt, :function expandFlt], - ['%fmaxval, :function expandFmaxval], - ['%fminval, :function expandFminval], - ['%fneg, :function expandFneg], - ['%fprec, :function expandFprec], - ['%fcstpi, :function expandFcstpi], - - ['%streq, :function expandStreq], - ['%strlt, :function expandStrlt], - ['%strstc, :function expandStrstc], - - ['%bitvecnot, :function expandBitvecnot], - ['%bitvecand, :function expandBitvecand], - ['%bitvecnand, :function expandBitvecnand], - ['%bitvecor, :function expandBitvecor], - ['%bitvecxor, :function expandBitvecxor], - ['%bitvecnor, :function expandBitvecnor], - ['%bitveclength, :function expandBitveclength], - ['%bitveccopy, :function expandBitveccopy], - ['%bitvecconc, :function expandBitvecconc], - ['%bitveceq, :function expandBitveceq], - ['%bitvecref, :function expandBitvecref], - ['%makebitvec, :function expandMakebitvec], - - ['%peq, :function expandPeq], - ['%before?, :function expandBefore?], - - ['%bind, :function expandBind], - ['%store, :function expandStore], - ['%dynval, :function expandDynval], - ['%throw, :function expandThrow], - ['%try, :function expandTry] - ] repeat property(first x,'%Expander) := rest x - -++ Return the expander of a middle-end opcode, or nil if there is none. -getOpcodeExpander op == - op has %Expander - -++ Expand all opcodes contained in the form `x' into a form -++ suitable for evaluation by the VM. -expandToVMForm x == - x = '%false or x = '%nil => 'NIL - IDENTP x and (x' := x has %Rename) => x' - atomic? x => x - [op,:args] := x - IDENTP op and (fun:= getOpcodeExpander op) => apply(fun,x,nil) - op' := expandToVMForm op - args' := expandToVMForm args - EQ(op,op') and EQ(args,args') => x - [op',:args'] - ++ $interpOnly := false |