diff options
| -rw-r--r-- | src/ChangeLog | 15 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 104 | ||||
| -rw-r--r-- | src/interp/comp.lisp | 102 |
3 files changed, 122 insertions, 99 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 279725d7..5fb64461 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,18 @@ +2008-10-10 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * interp/c-util.boot ($middleEndMacroList): New. + (middleEndExpand): New. + (backendCompileILAM): Bootify COMP-ILAM. + (backendCompileSLAM): Bootify COMP-SLAM. + (backendCompileSPADSLAM): Bootify COMP-SPADSLAM. + * interp/comp.lisp (COMP-2): Use them. + (COMP-ILAM): Remove. + (COMP-SLAM): Likewise. + (COMP-SPADLSAM): Likewise. + (COMP-TRAN): Use middleEndExpand. + (COMP-EXPAND): Remove. + ($COMP-MACROLIS): Likewise. + 2008-10-09 Gabriel Dos Reis <gdr@cs.tamu.edu> * boot/translator.boot (loadNativeModule): Don't save loaded diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 27abe533..c7c9443a 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -895,6 +895,26 @@ updateCapsuleDirectory(entry,pred) == --% +++ List of macros used by the middle end to represent some +++ high level control structures. +-- NOTE: It is potentially dangerous to assume every occurrence of +-- element of $middleEndMacroList is actually a macro call +$middleEndMacroList == + '(COLLECT REPEAT SUCHTHATCLAUSE THETA COLLECTV + COLLECTVEC THETA1 SPADREDUCE SPADDO) + +middleEndExpand: %Form -> %Form +middleEndExpand x == + isAtomicForm x => x + first x in $middleEndMacroList => + middleEndExpand MACROEXPAND_-1 x + a := middleEndExpand first x + b := middleEndExpand rest x + EQ(a,first x) and EQ(b,rest x) => x + [a,:b] + + + -- A function is simple if it looks like a super combinator, and it -- does not use its environment argument. They can be safely replaced -- by more efficient (hopefully) functions. @@ -993,7 +1013,7 @@ setCompilerOptimizations level == coreError '"unknown optimization level request" ---% +--% Lisp backend support. ++ Proclaim the type of the capsule function `op' with signature `sig'. ++ Note that all capsule functions take an additional argument @@ -1019,3 +1039,85 @@ proclaimCapsuleFunction(op,sig) == getmode(d,$e) => "*" d [first d, :[normalize(first args,false) for args in tails rest d]] + +++ Lisp back end compiler for ILAM with `name', formal `args', and `body'. +backendCompileILAM: (%Symbol,%List, %Code) -> %Symbol +backendCompileILAM(name,args,body) == + args' := NLIST(#args, ["GENSYM"]) + body' := eqSubst(args',args,body) + MAKEPROP(name,"ILAM",true) + setDynamicBinding(name,["LAMBDA",args',:body']) + name + + +++ Lisp back end compiler for SLAM forms [namd,args,:body]. +++ A SLAM form is one that is `functional' in the sense that +++ its values are cached, so that equal lists of argument values +++ yield equal values. The arguments-value pairs are stored +++ as alists. +backendCompileSLAM: (%Symbol,%List,%Code) -> %Symbol +backendCompileSLAM(name,args,body) == + al := INTERNL(name,'";AL") -- name of the cache alist. + auxfn := INTERNL(name,'";") -- name of the worker function. + g1 := GENSYM() -- name for the parameter. + g2 := GENSYM() -- name for the cache value + u := -- body of the stub function + null args => [nil,[auxfn]] + null rest args => [[g1],[auxfn,g1]] + [g1,["APPLX", ["FUNCTION",auxfn], g1]] + arg := first u + app := second u + codePart1 := -- look up the value if it is already there + args ^= nil => [["SETQ", g2, ["assoc",g1,al]], ["CDR",g2]] + [al] + codePart2 := -- otherwise, compute it. + args ^= nil => [true,["SETQ",g2,app],["SETQ",al,[[g1,:g2],:al]],g2] + [true,["SETQ",al,app]] + lamex := ["LAM",arg,["PROG",[g2], + ["RETURN",["COND",codePart1,codePart2]]]] + setDynamicBinding(al,nil) -- clear the cache + -- compile the worker function, first. + u := [auxfn,["LAMBDA",args,:body]] + COMP370 [u] + -- then compile the original function. + u := [name,lamex] + if $PrettyPrint then PRETTYPRINT u + COMP370 [u] + name + +++ Same as backendCompileSPADSLAM, except that the cache is a hash +++ table. This backend compiler is used to compile constructors. +backendCompileSPADSLAM: (%Symbol,%List,%Code) -> %Symbol +backendCompileSPADSLAM(name,args,body) == + al := INTERNL(name,'";AL") -- name of the cache hash table. + auxfn := INTERNL(name,'";") -- name of the worker function. + g1 := GENSYM() -- name of the worker function parameter + g2 := GENSYM() -- name for the cache value. + u := + null args => [nil,nil,[auxfn]] + null rest args => [[g1],["devaluate",g1],[auxfn,g1]] + [g1,["devaluateList",g1],["APPLY",["FUNCTION",auxfn],g1]] + arg := first u + argtran := second u -- devaluate argument + app := third u + codePart1 := -- if value already computed, grab it. + null args = nil => [al] + [["SETQ",g2,["assoc",argtran,al]], ["CDR",g2]] + codePart2 := -- otherwise compute it, and cache it. + -- Note: at most five values are cached. + null args = nil => [true,["SETQ",al,app]] + [true,["SETQ",al,["cons5",["CONS",argtran, ["SETQ",g2,app]],al]],g2] + decl := -- declare the cache variable. + null args => nil + [g2] + lamex := ["LAM",arg,["LET",decl,["COND",codePart1,codePart2]]] + SETANDFILE(al,nil) -- define the global cache. + -- compile the worker function first. + u := [auxfn,["LAMBDA",args,:body]] + if $PrettyPrint then PRETTYPRINT u + COMP370 [u] + -- then compiler the stub (which is the user-visible constructor). + u := [name,lamex] + if $PrettyPrint then PRETTYPRINT u + COMP370 [u] + name diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp index 2a52d020..c8bdb9fb 100644 --- a/src/interp/comp.lisp +++ b/src/interp/comp.lisp @@ -86,10 +86,10 @@ (defun Comp-2 (args &aux name type argl bodyl junk) (dsetq (NAME (TYPE ARGL . BODYL) . JUNK) args) (cond (JUNK (MOAN (format nil "******pren error in (~S (~S ...) ...)" NAME TYPE))) - ((eq TYPE 'SLAM) (COMP-SLAM NAME ARGL BODYL)) + ((eq TYPE 'SLAM) (|backendCompileSLAM| NAME ARGL BODYL)) ((LASSQ NAME |$clamList|) (|compClam| NAME ARGL BODYL |$clamList|)) - ((eq TYPE 'SPADSLAM) (COMP-SPADSLAM NAME ARGL BODYL)) - ((eq TYPE 'ILAM) (COMP-ILAM NAME ARGL BODYL)) + ((eq TYPE 'SPADSLAM) (|backendCompileSPADSLAM| NAME ARGL BODYL)) + ((eq TYPE 'ILAM) (|backendCompileILAM| NAME ARGL BODYL)) ((setq BODYL (LIST NAME (CONS TYPE (CONS ARGL BODYL)))) (if |$PrettyPrint| (pprint bodyl)) (if (null $COMPILE) (SAY "No Compilation") @@ -99,81 +99,6 @@ ;; used to be called POSN - but that interfered with a CCL function (DEFUN POSN1 (X L) (position x l :test #'equal)) -(DEFUN COMP-ILAM (NAME ARGL BODYL) - (let* ((FARGL (NLIST (LENGTH ARGL) '(GENSYM))) - (BODYLP (SUBLISLIS FARGL ARGL BODYL))) - (MAKEPROP NAME 'ILAM T) - (SET NAME (CONS 'LAMBDA (CONS FARGL BODYLP))) - NAME)) - -(DEFUN COMP-SPADSLAM (NAME ARGL BODYL) - (let* ((AL (INTERNL NAME ";AL")) - (AUXFN (INTERNL NAME ";")) - (G1 (GENSYM)) - (G2 (GENSYM)) - (U (COND ((NOT ARGL) (LIST NIL NIL (LIST AUXFN))) - ((NOT (CDR ARGL)) - (LIST (LIST G1) (LIST '|devaluate| G1) (LIST AUXFN G1))) - ((LIST G1 - (LIST '|devaluateList| G1) - (LIST 'APPLY (LIST 'FUNCTION AUXFN) G1))))) - (ARG (first U)) - (ARGTRAN (second U)) - (APP (third U)) - (LAMEX `(lam ,ARG - (let (,g2) - (cond ,(COND (ARGL `((setq ,g2 (|assoc| ,argtran ,al)) - (cdr ,g2))) - ((LIST AL))) - ,(COND (ARGL - `(t(setq ,al(|cons5|(cons ,argtran - (setq ,g2 ,app)) - ,al)) - ,g2)) - (`(t (setq ,al ,app))))))))) - (setandfile AL NIL) - (setq U (LIST NAME LAMEX)) - (if |$PrettyPrint| (PRETTYPRINT U)) - (COMP370 (LIST U)) - (setq U (LIST AUXFN (CONS 'LAMBDA (CONS ARGL BODYL)))) - (COND (|$PrettyPrint| (PRETTYPRINT U))) - (COMP370 (LIST U)) - NAME)) - -(DEFUN COMP-SLAM (NAME ARGL BODYL) - (let* ((AL (INTERNL NAME ";AL")) - (AUXFN (INTERNL NAME ";")) - (G1 (GENSYM)) - (G2 (GENSYM)) - (U (COND ((NOT ARGL) `(nil (,auxfn))) - ((NOT (CDR ARGL)) `((,g1)(,auxfn ,g1))) - (`(,g1 (applx (function ,auxfn) ,g1))))) - (ARG (CAR U)) - (APP (CADR U)) - (LAMEX - (LIST 'LAM ARG - (LIST 'PROG (LIST G2) - (LIST 'RETURN - (LIST 'COND - (COND (ARGL - `((setq ,G2 (|assoc| ,G1 ,AL)) - (CDR ,G2))) - ((LIST AL))) - (COND (ARGL (LIST ''T `(setq ,G2 ,APP) - (LIST 'SETQ AL - `(CONS - (CONS ,G1 ,G2) ,AL)) - G2)) - ((LIST ''T `(setq ,AL ,APP)))))))))) - (set AL NIL) - (setq U (LIST NAME LAMEX)) - (if |$PrettyPrint| (PRETTYPRINT U)) - (COMP370 (LIST U)) - (setq U (LIST AUXFN (CONS 'LAMBDA (CONS ARGL BODYL)))) - (if |$PrettyPrint| (PRETTYPRINT U)) - (COMP370 (LIST U)) - NAME)) - (DEFUN COMP-NEWNAM (X) (let (y u) (cond ((ATOM X) NIL) @@ -192,7 +117,7 @@ (DEFUN COMP-TRAN (X) "SEXPR<FN. BODY> -> SEXPR" - (let ((X (COMP-EXPAND X)) FluidVars LocVars SpecialVars) + (let ((X (|middleEndExpand| X)) FluidVars LocVars SpecialVars) (COMP-TRAN-1 (CDDR X)) (setq X (list (first x) (second x) (if (and (null (cdddr x)) @@ -250,25 +175,6 @@ (RETURN X)) ('T (RETURN (CONS A B)) )) ) ))) -; NOTE: It is potentially dangerous to assume every occurrence of element of -; $COMP-MACROLIST is actually a macro call - -(defparameter $COMP-MACROLIST - '(COLLECT REPEAT SUCHTHATCLAUSE THETA COLLECTV COLLECTVEC - THETA1 SPADREDUCE SPADDO) - "???") - -(DEFUN COMP-EXPAND (X) - (COND ((atom x) x) - ((eq (CAR X) 'QUOTE) X) - ((memq (CAR X) $COMP-MACROLIST) - (comp-expand (macroexpand-1 x))) - ((let ((a (comp-expand (car x))) - (b (comp-expand (cdr x)))) - (if (AND (eq A (CAR X)) (eq B (CDR X))) - x - (CONS A B)))))) - (DEFUN COMP-TRAN-1 (X) (let (u) (cond ((ATOM X) NIL) |