aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/ChangeLog15
-rw-r--r--src/interp/c-util.boot104
-rw-r--r--src/interp/comp.lisp102
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)