-- Copyright (C) 2011-2022, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --% --% The purpose of this module is to implement the Lisp backend --% of the OpenAxiom platform. This is achieved by necessary --% collection runtime datatypes and Common Lisp code generation --% routines. --% import sys_-macros import nlib import c_-util namespace BOOT module lisp_-backend where expandToVMForm: %Thing -> %Thing eval: %Thing -> %Thing printBackendStmt: (%Libstream,%Code) -> %Void transformToBackendCode: %Form -> %Code --% --% 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 loopVarInit(x,y) == x is ['%free,:id] => [id,nil] -- no init form for free iterators. if x is ['%local,:.] then x := x.rest [x,[x,y]] ++ 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? or x is ['%free,:.] => -- give the loop variable a wider scope. [x,init] := loopVarInit(x,'%nil) init := init = nil => [[g,l]] [[g,l],init] [init,nil,[['%store,g,['%tail,g]]],nil, [['%not,['%pair?,g]],['%seq,['%store,x,['%head,g]],'%nil]]] [x,init] := loopVarInit(x,['%head,g]) [[[g,l]], [init],[['%store,g,['%tail,g]]], nil,[['%not,['%pair?,g]]]] expandON(x,l) == [x,init] := loopVarInit(x,l) if init ~= nil then init := [init] [init,nil,[['%store,x,['%tail,x]]],nil,[['%not,['%pair?,x]]]] ++ Generate code that traverses an interval with lower bound 'lo', ++ arithmetic progression `step, and possible upper bound `final'. expandSTEP(id,lo,step,final)== [id,init] := loopVarInit(id,lo) loopvar := init = nil => nil [init] inc := atomic? step => step g1 := gensym() loopvar := [:loopvar,[g1,step]] g1 final := final isnt [.,:.] => final final is [hi] and atomic? hi => hi g2 := gensym() loopvar := [:loopvar,[g2,:final]] g2 ex := final = nil => nil integer? inc => pred := inc < 0 => '%ilt '%igt [[pred,id,final]] [['%when,[['%ilt,inc,0], ['%ilt,id,final]],['%otherwise,['%igt,id,final]]]] suc := [['%store,id,['%iadd,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,[p],nil] ++ Generate code for iterators that stop loop iteration when the ++ state fails predicate `p'. expandWHILE p == [nil,nil,nil,nil,[['%not,p]]] expandUNTIL p == g := gensym() [[[g,'%false]],nil,[['%store,g,p]],nil,[g]] expandInit(var,val) == [[[var,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 expandRepeat ['%repeat,:iters,body,ret] == itersCode := expandIterators iters itersCode is "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 := ['%bind,bodyInits,body] exits := exits = nil => body ['%when,[mkpf(exits,"OR"),["RETURN",expandToVMForm ret]], ['%otherwise,body]] body := ['%loop,exits,:cont] -- Finally, set up loop-wide initializations. if loopInits ~= nil then body := ['LET,loopInits,body] expandToVMForm optimize! body ++ Generate code for list comprehension. expandCollect ['%collect,:iters,body] == expandRepeat finishListCollect(iters,body) expandList(x is ['%list,: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] quote args' expandArray2List ['%array2list,x] == ['COERCE,expandToVMForm x,quote 'LIST] expandLeave ['%leave,l,x] == x := expandToVMForm x l = nil => ['RETURN,x] ['RETURN_-FROM,l,x] expandReturn(x is ['%return,.,y]) == $FUNNAME = nil => systemErrorHere ['expandReturn,x] ['RETURN_-FROM,$FUNNAME,expandToVMForm y] ++ Subroutine of expandSeq. ++ Return true if the form `x' contains no %exit form. hasNoExit? x == atomic? x => true x is ['%exit,:.] => false and/[hasNoExit? s for s in x] ++ Expand a sequence of statements with possible non-local ++ lexical control transfer. Attempt to recognize those with ++ normal lexical exit. expandSeq(x is ['%seq,:stmts]) == [:stmts',val] := stmts val is ['%exit,val'] and hasNoExit? val' and (and/[hasNoExit? s for s in stmts']) => ['PROGN,:[expandToVMForm s for s in stmts'],expandToVMForm val'] op := and/[hasNoExit? s for s in stmts] => 'PROGN 'SEQ [op,:[expandToVMForm s for s in stmts]] -- 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 => ['PLUSP,expandToVMForm y] integer? y and y = 0 => ['MINUSP,expandToVMForm x] ['_<,expandToVMForm x,expandToVMForm y] expandIgt ['%igt,x,y] == expandIlt ['%ilt,y,x] expandIbigrandom ['%ibigrandom] == ['RANDOM,['GET_-INTERNAL_-REAL_-TIME]] -- 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,quote '%DoubleFloat] expandFsqrt ['%fsqrt,x] == ['C_-TO_-R,['SQRT,expandToVMForm x]] expandFpowf ['%fpowf,x,y] == ['C_-TO_-R,['EXPT,expandToVMForm x,expandToVMForm y]] expandFlog ['%flog,x] == ['C_-TO_-R,['LOG,expandToVMForm x]] expandFlog2 ['%flog2,x] == ['C_-TO_-R,['LOG,expandToVMForm x,2]] expandFlog10 ['%flog10,x] == ['C_-TO_-R,['LOG,expandToVMForm x,10]] expandFasin ['%fasin,x] == ['C_-TO_-R,['ASIN,expandToVMForm x]] expandFacos ['%facos,x] == ['C_-TO_-R,['ACOS,expandToVMForm x]] expandFacosh ['%facosh,x] == ['C_-TO_-R,['ACOSH,expandToVMForm x]] expandFatanh ['%fatanh,x] == ['C_-TO_-R,['ATANH,expandToVMForm x]] expandFacoth ['%facoth,x] == ['C_-TO_-R,['ACOTH,expandToVMForm x]] expandFdecode ['%fdecode,x] == ['MULTIPLE_-VALUE_-CALL,['FUNCTION,'LIST], ['INTEGER_-DECODE_-FLOAT,expandToVMForm x]] -- 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] expandBytevec2str ['%bytevec2str,x] == ['MAP,quote 'STRING, --FIXME: should be '%String, fix when SBCL is fixed. ['FUNCTION,['LAMBDA,['c],['CODE_-CHAR,'c]]],expandToVMForm x] expandStr2bytevec ['%str2bytevec,x] == ['MAP,quote ['%Vector,'%Byte], ['FUNCTION,['LAMBDA,['c],['CHAR_-CODE,'c]]],expandToVMForm x] -- 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, quote '%BitVector,expandToVMForm x,expandToVMForm y] expandBitvecref ['%bitvecref,x,y] == ['SBIT,expandToVMForm x,expandToVMForm y] expandBitveceq ['%bitveceq,x,y] == ['EQUAL,expandToVMForm x,expandToVMForm y] expandBitvector ['%bitvector,x,y] == ['MAKE_-ARRAY,['LIST,expandToVMForm x], KEYWORD::ELEMENT_-TYPE,quote '%Bit, KEYWORD::INITIAL_-ELEMENT,expandToVMForm y] --% complex number conversions --% An OpenAxiom complex number is a pair (real and imaginary parts.) -- convert an OpenAxiom complex number to a Lisp complex number expandVal2z ['%val2z,x] == cons? x => g := gensym() expandToVMForm ['%bind,[[g,x]],['%zlit,['%head,g],['%tail,g]]] expandToVMForm ['%zlit,['%head,x],['%tail,x]] -- convert a Lisp complex number to an OpenAxiom complex number expandZ2val ['%z2val,x] == cons? x => g := gensym() expandToVMForm ['%bind,[[g,x]],['%pair,['%zreal,g],['%zimag,g]]] expandToVMForm ['%pair,['%zreal,x],['%zimag,x]] -- 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,['%otherwise,['THROW,$OpenAxiomCatchTag,g]]] ['%when, [['%and,['%pair?,g], ['%peq,['%head,g],$OpenAxiomCatchTag]], ['%when,:ys]], ['%otherwise,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 [ -- Lisp keywords ['%elementType, : KEYWORD::ELEMENT_-TYPE], ['%initialElement, : KEYWORD::INITIAL_-ELEMENT], ['%initialContents, : KEYWORD::INITIAL_-CONTENTS], -- Boolean constants -- ['%false, :'NIL], ['%true, :'T], -- unary Boolean operations ['%not, :'NOT], -- binary Boolean operations ['%and, :'AND], ['%or, :'OR], -- character operations ['%ccstmax,:'_$CharCodeMaximum], ['%ceq, :'CHAR_=], ['%clt, :'CHAR_<], ['%cle, :'CHAR_<_=], ['%cgt, :'CHAR_>], ['%cge, :'CHAR_>_=], ['%cup, :'CHAR_-UPCASE], ['%cdown, :'CHAR_-DOWNCASE], ['%c2i, :'CHAR_-CODE], ['%i2c, :'CODE_-CHAR], ['%c2s, :'STRING], -- byte operations ['%beq, :'byteEqual], ['%blt, :'byteLessThan], -- integer constants ['%icst0, :0], ['%icst1, :1], ['%icstmin, :'_$ShortMinimum], ['%icstmax, :'_$ShortMaximum], -- unary integer operations. ['%iabs, :'ABS], ['%ieven?, :'EVENP], ['%integer?,:'INTEGERP], ['%iodd?, :'ODDP], ['%ismall?, :'fixnum?], ['%i2s, :'WRITE_-TO_-STRING], ['%ilength, :'INTEGER_-LENGTH], ['%ibit, :'INTEGER_-BIT], ['%irandom, :'RANDOM], -- binary integer operations. ['%iadd, :"+"], ['%igcd, :'GCD], ['%ige, :">="], ['%iinc, :"1+"], ['%idec, :"1-"], ['%ilcm, :'LCM], ['%ile, :"<="], ['%imax, :'MAX], ['%imin, :'MIN], ['%imul, :"*"], ['%imulf, :"*"], -- integer * float ['%irem, :'REM], ['%ilshift, :'ASH], ['%irshift, :'ASH], ['%iquo, :'TRUNCATE], ['%ipow, :'EXPT], ['%isub, :"-"], ['%bitand, :'LOGAND], ['%bitior, :'LOGIOR], ['%bitxor, :'LOGXOR], ['%bitnot, :'LOGNOT], -- unary float operations. ['%fabs, :'ABS], ['%float?,:'FLOATP], ['%ftrunc,:'TRUNCATE], -- binary float operations. ['%fadd, :"+"], ['%fdiv, :"/"], ['%fdivi, :"/"], -- float / integer ['%fge, :">="], ['%fle, :"<="], ['%fmax, :'MAX], ['%fmin, :'MIN], ['%fmul, :"*"], ['%fpowi, :'EXPT], ['%fsub, :"-"], ['%fmanexp, :'MANEXP], -- (mantissa, exponent) pair. ['%fexp, :'EXP], ['%fsin, :'SIN], ['%fcos, :'COS], ['%ftan, :'TAN], ['%fcot, :'COT], ['%fatan, :'ATAN], ['%facot, :'ACOT], ['%fsinh, :'SINH], ['%fcosh, :'COSH], ['%ftanh, :'TANH], ['%fasinh, :'ASINH], -- complex number operations ['%zlit, :'COMPLEX], ['%zreal, :'REALPART], ['%zimag, :'IMAGPART], ['%zexp, :'EXP], ['%zlog, :'LOG], ['%zsin, :'SIN], ['%zcos, :'COS], ['%ztan, :'TAN], ['%zasin, :'ASIN], ['%zacos, :'ACOS], ['%zatan, :'ATAN], ['%zsinh, :'SINH], ['%zcosh, :'COSH], ['%ztanh, :'TANH], ['%zasinh, :'ASINH], ['%zacosh, :'ACOSH], ['%zatanh, :'ATANH], -- string operations ['%f2s, :'DFLOAT_-FORMAT_-GENERAL], -- list contants -- ['%nil, :'NIL], -- unary list operations ['%head, :'CAR], ['%pair, :'CONS], ['%lempty?, :'NULL], ['%lfirst, :'CAR], ['%llength, :'LIST_-LENGTH], ['%lreverse, :'reverse], ['%lreverse!, :'reverse!], ['%lsecond, :'CADR], ['%lthird, :'CADDR], ['%pair?, :'CONSP], ['%tail, :'CDR], ['%lcopy, :'COPY_-LIST], -- binary list operations ['%lconcat, :'APPEND], -- simple vector operations ['%array, :'MAKE_-ARRAY], ['%vfill, :'FILL], ['%vlength, :'sizeOfSimpleArray], ['%vector, :'VECTOR], ['%vref, :'SVREF], ['%aref, :'getSimpleArrayEntry], ['%makevector,:'MAKE_-ARRAY], ['%vcopy, :'COPY_-SEQ], -- symbol unary functions ['%gensym, :'GENSYM], ['%sname, :'SYMBOL_-NAME], ['%ident?, :'ident?], ['%property,:'GET], -- string functions ['%string?, :'STRINGP], ['%strlength, :'LENGTH], ['%schar, :'CHAR], ['%strconc, :'STRCONC], ['%strcopy, :'COPY_-SEQ], -- general utility ['%type2form,:'getVMType], ['%hash, :'SXHASH], ['%equal, :'EQUAL], ['%tref, :'shellEntry], ['%sptreq, :'EQL], -- system pointer equality ['%otherwise,:'T], ['%closure, :'CONS], ['%loop, :'LOOP], ['%funcall, :'FUNCALL], ['%function, :'FUNCTION], ['%lambda, :'LAMBDA], ['%exit, :'EXIT], ['%when, :'COND], ['%scope, :'BLOCK], ['%constant, :['FUNCTION,'IDENTITY]], -- I/O stream functions ['%writeString, :'WRITE_-STRING], ['%writeNewline, :'TERPRI], ['%writeLine, :'WRITE_-LINE] ] repeat property(first x,'%Rename) := rest x ++ Table of opcode-expander pairs. for x in [ ['%list, :function expandList], ['%array2list, :function expandArray2List], ['%collect, :function expandCollect], ['%repeat, :function expandRepeat], ['%return, :function expandReturn], ['%leave, :function expandLeave], ['%seq, :function expandSeq], ['%bcompl, :function expandBcompl], ['%ccst, :function expandCcst], ['%s2c, :function expandS2c], ['%ieq, :function expandIeq], ['%igt, :function expandIgt], ['%ilt, :function expandIlt], ['%ineg, :function expandIneg], ['%idivide, :function expandIdivide], ['%ibigrandom, :function expandIbigrandom], ['%i2f, :function expandI2f], ['%fdecode, :function expandFdecode], ['%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], ['%fsqrt, :function expandFsqrt], ['%fpowf, :function expandFpowf], ['%flog, :function expandFlog], ['%flog2, :function expandFlog2], ['%flog10, :function expandFlog10], ['%fasin, :function expandFasin], ['%facos, :function expandFacos], ['%facosh, :function expandFacosh], ['%fatanh, :function expandFatanh], ['%facoth, :function expandFacoth], ['%z2val, :function expandZ2val], ['%val2z, :function expandVal2z], ['%streq, :function expandStreq], ['%strlt, :function expandStrlt], ['%strstc, :function expandStrstc], ['%bytevec2str, :function expandBytevec2str], ['%str2bytevec, :function expandStr2bytevec], ['%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], ['%bitvector, :function expandBitvector], ['%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 is '%false or x is '%nil => 'NIL x is '%undefined => 'NIL -- for the time being. FIXME. ident? x and (x' := x has %Rename) => x' atomic? x => x [op,:args] := x ident? op and (fun:= getOpcodeExpander op) => apply(fun,[x]) op' := expandToVMForm op args' := expandToVMForm args sameObject?(op,op') and sameObject?(args,args') => x [op',:args'] ++ Evaluate an OpenAxiom VM form. Eventually, this function is ++ to be provided as a builtin by a OpenAxiom target machine. eval x == EVAL expandToVMForm x ++ Augment the current evaluation environment with a function definition. evaluateLispDefinition body == eval body ++ Return true if `parms' is the empty list ++ or is a proper list of identifiers. simpleParameterList? parms == parms = nil => true parms is [.,:.] and lastNode parms is [.] and (and/[ident? p for p in parms]) removeFluids args == args = nil => args ident? args => $Vars := [args,:$Vars] args args isnt [.,:.] => args := gensym() $Vars := [args,:$Vars] args args is ['FLUID,v] and ident? v => $Decls := [v,:$Decls] $Vars := [v,:$Vars] v [removeFluids first args,:removeFluids rest args] COMPILE1 fun == $Vars: local := nil $Decls: local := nil [name,lambda] := fun [type,args,:body] := lambda if body is [['DECLARE,['SPECIAL,:xs]],:body'] then $Decls := xs body := body' args := removeFluids args newArgs := type in '(%lambda LAMBDA) and simpleParameterList? args => args args' := gensym() body := [['DSETQ,args,args'],:body] type in '(%lambda LAMBDA) => ["&REST",args',"&AUX",:$Vars] type is 'MLAMBDA => ["&WHOLE",args',"&REST",gensym(),"&AUX",:$Vars] systemError ['"bad function type: ",:bright symbolName type] if $Decls ~= nil then body := [['DECLARE,['SPECIAL,:$Decls]],:body] body := type in '(%lambda LAMBDA) => ['DEFUN,name,newArgs,:body] ['DEFMACRO,name,newArgs,:body] apply($backend,[body]) body COMP370 x == first x is [.,:.] => [COMPILE1 y for y in x] [COMPILE1 x] assembleCode x == if $PrettyPrint then PRETTYPRINT x if not $COMPILE then SAY '"No Compilation" else COMP370 x first x printBackendStmt(lib,stmt) == st := libCodeStream lib PRINT_-FULL(stmt,st) flushOutput st ++ Replace every middle end sub-forms in `x' with Lisp code. massageBackendCode: %Code -> %Void massageBackendCode x == ident? x and isLispSpecialVariable x => noteSpecialVariable x atomic? x => nil -- temporarily have TRACELET report MAKEPROPs. if (u := first x) = "MAKEPROP" and $TRACELETFLAG then x.op := "MAKEPROP-SAY" u in '(DCQ SETQ %LET) => if u = '%LET then if x.args is [y,.] and ident? y then x.op := "SETQ" else x.op := "LETT" append!(x,$FUNNAME__TAIL) massageBackendCode CDDR x if u ~= "SETQ" then ident? second x => pushLocalVariable second x second x is ["FLUID",:.] => PUSH(CADADR x, $FluidVars) x.rest.first := CADADR x for v in LISTOFATOMS second x repeat pushLocalVariable v -- Even if user used Lisp-level instructions to assign to -- this variable, we still want to note that it is a Lisp-level -- special variable. u is 'SETQ and isLispSpecialVariable second x => noteSpecialVariable second x u in '(LET LET_*) => oldVars := $LocalVars vars := nil for [var,init] in second x repeat massageBackendCode init $LocalVars := [var,:$LocalVars] vars := [var,:vars] massageBackendCode x.rest.rest newVars := setDifference($LocalVars,setUnion(vars,oldVars)) $LocalVars := setUnion(oldVars,newVars) u in '(PROG LAMBDA) => newBindings := [] for y in second x repeat not symbolMember?(y,$LocalVars) => $LocalVars := [y,:$LocalVars] newBindings := [y,:newBindings] res := massageBackendCode CDDR x $LocalVars := REMOVE_-IF(function (y +-> y in newBindings), $LocalVars) [u,second x,:res] u = "DECLARE" => nil -- there is nothing to do convert there massageBackendCode u massageBackendCode rest x skipDeclarations: %List %Code -> %List %Code skipDeclarations form == while first form is ["DECLARE",:.] repeat form := rest form form ++ return the last node containing a declaration in form, otherwise nil. lastDeclarationNode: %List %Code -> %List %Code lastDeclarationNode form == while second form is ["DECLARE",:.] repeat form := rest form first form is ["DECLARE",:.] => form nil declareGlobalVariables: %List %Symbol -> %Code declareGlobalVariables vars == ["DECLARE",["SPECIAL",:vars]] ++ Return true if `form' contains an EXIT-form that matches ++ the parent node of `form'. matchingEXIT form == atomic? form or form.op is 'SEQ => false form.op is 'EXIT => true or/[matchingEXIT x for x in form] simplifySEQ form == atomic? form => form form is ["SEQ",[op,a]] and op in '(EXIT RETURN) => simplifySEQ a form is ['SEQ,s] and not matchingEXIT s => simplifySEQ s for stmts in tails form repeat stmts.first := simplifySEQ first stmts form ++ Return true if the Lisp `form' has a `RETURN' form ++ that needs to be enclosed in a `PROG' form. needsPROG? form == atomic? form => false op := form.op op is 'RETURN => true op in '(LOOP PROG) => false form is ['BLOCK,=nil,:.] => false any?(function needsPROG?,form) ++ We are processing the complete `body' of a function definition. ++ If this body is a multiway test, there is no need to have ++ a RETURN-FROM operator in the immediate consequence of a branch. removeToplevelRETURN_-FROM body == if body is [['COND,:stmts]] then for stmt in stmts repeat stmt is [.,['RETURN_-FROM,.,expr]] => second(stmt) := expr body ++ Generate Lisp code by lowering middle end defining form `x'. ++ x has the strucrure: transformToBackendCode x == $FluidVars: local := nil $LocalVars: local := nil $SpecialVars: local := nil x := middleEndExpand x cleanParameterList! x.absParms massageBackendCode CDDR x body := skipDeclarations CDDR x -- Make it explicitly a sequence of statements if it is not a one liner. body := body is [stmt] and (stmt isnt [.,:.] or stmt.op in '(SEQ LET LET_*) or not CONTAINED("EXIT",stmt)) => body [simplifySEQ ["SEQ",:body]] $FluidVars := removeDuplicates reverse! $FluidVars $LocalVars := S_-(S_-(removeDuplicates reverse! $LocalVars,$FluidVars), LISTOFATOMS second x) lvars := [:$FluidVars,:$LocalVars] fluids := S_+($FluidVars,$SpecialVars) body := fluids ~= nil => lvars ~= nil or needsPROG? body => [["PROG",lvars,declareGlobalVariables fluids, ["RETURN",:body]]] body is [[op,inits,:body']] and op in '(LET LET_*) and $FluidVars ~= nil => [declareGlobalVariables $SpecialVars, [op,inits,declareGlobalVariables fluids,:body']] [declareGlobalVariables fluids,:body] lvars ~= nil or needsPROG? body => [["PROG",lvars,["RETURN",:body]]] removeToplevelRETURN_-FROM body -- add reference parameters to the list of special variables. fluids := S_+(backendFluidize second x, $SpecialVars) lastdecl := lastDeclarationNode rest x if lastdecl = nil then x.rest.rest := body else null fluids => lastdecl.rest := body lastdecl.rest := [declareGlobalVariables fluids,:body] x $CLOSEDFNS := nil MAKE_-CLOSEDFN_-NAME() == makeSymbol strconc($FUNNAME,'"!", toString # $CLOSEDFNS) backendCompileNEWNAM: %Form -> %Void backendCompileNEWNAM x == atomic? x => nil y := first x y isnt [.,:.] => backendCompileNEWNAM rest x if y is "CLOSEDFN" then u := MAKE_-CLOSEDFN_-NAME() PUSH([u,second x], $CLOSEDFNS) x.first := "FUNCTION" x.rest.first := u backendCompileNEWNAM first x backendCompileNEWNAM rest x backendCompile1 x == fname := first x $FUNNAME: local := fname $FUNNAME__TAIL: local := [fname] lamex := second x $CLOSEDFNS: local := [] lamex := transformToBackendCode lamex backendCompileNEWNAM lamex -- Note that category constructors are evaluated before they -- their compiled, so this noise is not very helpful. if $verbose and functionSymbol? fname then formatToStdout('"~&~%;;; *** ~S REDEFINED~%",fname) [[fname,lamex],:$CLOSEDFNS] backendCompile(db,l) == [backendCompile2(db,f2) for f2 in [:backendCompile1(f1) for f1 in l]]