aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/c-util.boot104
-rw-r--r--src/interp/comp.lisp102
-rw-r--r--src/interp/compiler.boot6
-rw-r--r--src/interp/i-analy.boot2
-rw-r--r--src/interp/wi1.boot1
5 files changed, 107 insertions, 108 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index d2bd035a..c18d6b52 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1049,6 +1049,24 @@ backendCompileILAM(name,args,body) ==
setDynamicBinding(name,["LAMBDA",args',:body'])
name
+$CLOSEDFNS := nil
+
+MAKE_-CLOSEDFN_-NAME() ==
+ INTERNL($FUNNAME,'"!", STRINGIMAGE # $CLOSEDFNS)
+
+backendCompileNEWNAM: %Form -> %Void
+backendCompileNEWNAM x ==
+ isAtomicForm x => nil
+ atom(y := first x) =>
+ backendCompileNEWNAM rest x
+ if y = "CLOSEDFN" then
+ u := MAKE_-CLOSEDFN_-NAME()
+ PUSH([u,second x], $CLOSEDFNS)
+ RPLACA(x,"FUNCTION")
+ RPLACA(rest x,u)
+ backendCompileNEWNAM first x
+ backendCompileNEWNAM rest x
+
++ Lisp back end compiler for SLAM forms [namd,args,:body].
++ A SLAM form is one that is `functional' in the sense that
@@ -1136,7 +1154,6 @@ backendCompile2 code ==
else COMP370 [body]
name
-
++ returns all fuild variables contained in `x'. Fuild variables are
++ identifiers starting with '$', except domain variable names.
backendFluidize x ==
@@ -1149,3 +1166,88 @@ backendFluidize x ==
a = nil => b
[a,:b]
+
+$FluidVars := []
+$LocalVars := []
+$SpecialVars := []
+
+
+++ push `x' into the list of local variables.
+pushLocalVariable: %Symbol -> %List
+pushLocalVariable x ==
+ x ^= "$" and (p := PNAME x).0 = char "$" and
+ p.1 ^= char "," and not DIGITP p.1 => nil
+ PUSH(x,$LocalVars)
+
+
+
+++ Replace every middle end sub-forms in `x' with Lisp code.
+mutateToBackendCode: %Form -> %Void
+mutateToBackendCode x ==
+ isAtomicForm x => nil
+ -- temporarily have TRACELET report MAKEPROPs.
+ if (u := first x) = "MAKEPROP" and $TRACELETFLAG then
+ RPLACA(x,"MAKEPROP-SAY")
+ u in '(DCQ RELET PRELET SPADLET SETQ %LET) =>
+ if u ^= "DCQ" then
+ $NEWSPAD or $FUNAME in $traceletFunctions =>
+ nconc(x,$FUNNAME__TAIL)
+ RPLACA(x,"LETT")
+ $TRACELETFLAG => RPLACA(x,"/TRACE-LET")
+ u = "%LET" => RPLACA(x,"SPADLET")
+ mutateToBackendCode CDDR x
+ if not (u in '(SETQ RELET)) then
+ IDENTP second x => pushLocalVariable second x
+ second x is ["FLUID",:.] =>
+ PUSH(CADADR x, $FluidVars)
+ rplac(second x, CADADR x)
+ MAPC(function pushLocalVariable, LISTOFATOMS second x)
+ IDENTP u and GET(u,"ILAM") ^= nil =>
+ RPLACA(x, eval u)
+ mutateToBackendCode x
+ u in '(PROG LAMBDA) =>
+ newBindings := []
+ for y in second x repeat
+ not (y in $LocalVars) =>
+ $LocalVars := [y,:$LocalVars]
+ newBindings := [y,:newBindings]
+ res := mutateToBackendCode CDDR x
+ $LocalVars := REMOVE_-IF(function LAMBDA(y(), y in newBindings),
+ $LocalVars)
+ [u,second x,:res]
+ mutateToBackendCode u
+ mutateToBackendCode rest x
+
+
+++ Generate Lisp code by lowering middle end form `x'.
+transformToBackendCode: %Form -> %Code
+transformToBackendCode x ==
+ $FluidVars: fluid := nil
+ $LocalVars: fluid := nil
+ $SpecialVars: fluid := nil
+ x := middleEndExpand x
+ mutateToBackendCode CDDR x
+ body :=
+ null CDDDR x and
+ (atom third x or first third x = "SEQ"
+ or not CONTAINED("EXIT",third x)) =>
+ third x
+ ["SEQ",:CDDR x]
+ x := [first x, second x, body]
+ $FluidVars := REMDUP nreverse $FluidVars
+ $LocalVars := S_-(S_-(REMDUP nreverse $LocalVars,$FluidVars),
+ LISTOFATOMS second x)
+ lvars := [:$FluidVars,:$LocalVars]
+ fluids := S_+($FluidVars,$SpecialVars)
+ x :=
+ fluids ^= nil =>
+ [first x, second x, ["PROG",lvars,["DECLARE","SPECIAL",:fluids],
+ ["RETURN",third x]]]
+ [first x, second x,
+ (lvars ^= nil or CONTAINED("RETURN",third x) =>
+ ["PROG",lvars,["RETURN",third x]]; third x)]
+ -- add reference parameters to the list of special variables.
+ fluids := S_+(backendFluidize second x, $SpecialVars)
+ null fluids => x
+ [first x, second x, ["DECLARE","SPECIAL",:fluids],:CDDR x]
+
diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp
index 46499b85..ad6b6520 100644
--- a/src/interp/comp.lisp
+++ b/src/interp/comp.lisp
@@ -58,13 +58,6 @@
;;; Common Block section
-(defparameter FluidVars nil)
-(defparameter LocVars nil)
-; (defparameter OptionList nil) defined in nlib.lisp
-(defparameter SpecialVars nil)
-
-(defvar $closedfns nil)
-
;; The following are used mainly in setvars.boot
(defun notEqualLibs (u v)
(if (string= u (library-name v)) (seq (close-library v) t) nil))
@@ -86,52 +79,6 @@
;; used to be called POSN - but that interfered with a CCL function
(DEFUN POSN1 (X L) (position x l :test #'equal))
-(DEFUN COMP-NEWNAM (X)
- (let (y u)
- (cond ((ATOM X) NIL)
- ((ATOM (setq Y (CAR X)))
- ;; (AND (IDENTP Y) (setq U (GET Y 'NEWNAM)) (RPLACA X U))
- (AND (NOT (eq Y 'QUOTE)) (COMP-NEWNAM (CDR X)))
- (WHEN (and (EQ Y 'CLOSEDFN) (boundp '$closedfns))
- (SETQ U (MAKE-CLOSEDFN-NAME))
- (PUSH (list U (CADR X)) $closedfns)
- (rplaca x 'FUNCTION)
- (rplaca (cdr x) u)))
- (t (COMP-NEWNAM (CAR X)) (COMP-NEWNAM (CDR X))))))
-
-(defun make-closedfn-name ()
- (internl $FUNNAME "!" (STRINGIMAGE (LENGTH $CLOSEDFNS))))
-
-(DEFUN COMP-TRAN (X)
- "SEXPR<FN. BODY> -> SEXPR"
- (let ((X (|middleEndExpand| X)) FluidVars LocVars SpecialVars)
- (COMP-TRAN-1 (CDDR X))
- (setq X (list (first x) (second x)
- (if (and (null (cdddr x))
- (or (atom (third x))
- (eq (car (third x)) 'SEQ)
- (not (contained 'EXIT (third x)))))
- (caddr x)
- (cons 'SEQ (cddr x))))) ;catch naked EXITs
- (let* ((FluidVars (REMDUP (NREVERSE FLUIDVARS)))
- (LOCVARS (S- (S- (REMDUP (NREVERSE LOCVARS)) FLUIDVARS)
- (LISTOFATOMS (CADR X))))
- (LVARS (append fluidvars LOCVARS)))
- (let ((fluids (S+ fluidvars SpecialVars)))
- (setq x
- (if fluids
- `(,(first x) ,(second x)
- (prog ,lvars (declare (special . ,fluids))
- (return ,(third x))))
- (list (first x) (second x)
- (if (or lvars (contained 'RETURN (third x)))
- `(prog ,lvars (return ,(third x)))
- (third x)) )))))
- (let ((fluids (S+ (|backendFluidize| (second x)) SpecialVars)))
- (if fluids
- `(,(first x) ,(second x) (declare (special . ,fluids)) . ,(cddr x))
- `(,(first x) ,(second x) . ,(cddr x))))))
-
; Fluidize: Returns a list of fluid variables in X
(DEFUN COMP\,FLUIDIZE (X) (COND
@@ -149,55 +96,6 @@
(RETURN X))
('T (RETURN (CONS A B)) )) ) )))
-(DEFUN COMP-TRAN-1 (X)
- (let (u)
- (cond ((ATOM X) NIL)
- ((eq (setq U (CAR X)) 'QUOTE) NIL)
- ((AND (eq U 'MAKEPROP) $TRACELETFLAG (RPLAC (CAR X) 'MAKEPROP-SAY) NIL)
- NIL)
- ; temporarily make TRACELET cause MAKEPROPs to be reported
- ((MEMQ U '(DCQ RELET PRELET SPADLET SETQ %LET) )
- (COND ((NOT (eq U 'DCQ))
- (COND ((OR (AND (eq $NEWSPAD T))
- (MEMQ $FUNNAME |$traceletFunctions|))
- (NCONC X $FUNNAME_TAIL)
- (RPLACA X 'LETT))
- ; this devious trick (due to RDJ) is needed since the compile
- ; looks only at global variables in top-level environment;
- ; thus SPADLET cannot itself test for such flags (7/83).
- ($TRACELETFLAG (RPLACA X '/TRACE-LET))
- ((eq U '%LET) (RPLACA X 'SPADLET)))))
- (COMP-TRAN-1 (CDDR X))
- (AND (NOT (MEMQ U '(setq RELET)))
- (COND ((IDENTP (CADR X)) (PUSHLOCVAR (CADR X)))
- ((EQCAR (CADR X) 'FLUID)
- (PUSH (CADADR X) FLUIDVARS)
- (RPLAC (CADR X) (CADADR X)))
- ((mapc #'pushlocvar (listofatoms (cadr x))) nil))))
- ((and (symbolp u) (GET U 'ILAM))
- (RPLACA X (EVAL U)) (COMP-TRAN-1 X))
- ((MEMQ U '(PROG LAMBDA))
- (PROG (NEWBINDINGS RES)
- (setq NEWBINDINGS NIL)
- (mapcar #'(lambda (Y)
- (COND ((NOT (MEMQ Y LOCVARS))
- (setq LOCVARS (CONS Y LOCVARS))
- (setq NEWBINDINGS (CONS Y NEWBINDINGS)))))
- (second x))
- (setq RES (COMP-TRAN-1 (CDDR X)))
- (setq locvars (remove-if #'(lambda (y) (memq y newbindings))
- locvars))
- (RETURN (CONS U (CONS (CADR X) RES)) )) )
- ((PROGN (COMP-TRAN-1 U) (COMP-TRAN-1 (CDR X)))))))
-
-(DEFUN PUSHLOCVAR (X)
- (let (p)
- (cond ((AND (NE X '$)
- (char= #\$ (ELT (setq P (PNAME X)) 0))
- (NOT (char= #\, (ELT P 1)))
- (NOT (DIGITP (ELT P 1)))) NIL)
- ((PUSH X LOCVARS)))))
-
(defmacro PRELET (L) `(spadlet . ,L))
(defmacro RELET (L) `(spadlet . ,L))
(defmacro PRESET (L) `(spadlet . ,L))
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index dc5f1211..99d44744 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -277,7 +277,7 @@ compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) ==
-- pass this as the environment to our inner function.
$FUNNAME :local := nil
$FUNNAME__TAIL :local := [nil]
- expandedFunction:=COMP_-TRAN CADR uu
+ expandedFunction:= transformToBackendCode second uu
frees:=FreeList(expandedFunction,vl,nil,e)
where FreeList(u,bound,free,e) ==
atom u =>
@@ -1928,8 +1928,8 @@ COMP_-1 x ==
$FUNNAME__TAIL := [fname]
lamex := second x
$CLOSEDFNS := []
- lamex := COMP_-TRAN lamex
- COMP_-NEWNAM lamex
+ 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 FBOUNDP fname then
diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot
index 45623e50..cbf3e34a 100644
--- a/src/interp/i-analy.boot
+++ b/src/interp/i-analy.boot
@@ -290,7 +290,7 @@ computeTypeWithVariablesTarget(p, q) ==
bottomUpCompile t ==
$genValue:local := false
ms := bottomUp t
- COMP_-TRAN_-1 objVal getValue t
+ mutateToBackendCode objVal getValue t
ms
bottomUpUseSubdomain t ==
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index 8693f7d4..a936733b 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -324,7 +324,6 @@ compWithMappingMode(x,m,oldE) ==
originalFun := u
if originalFun is ['WI,a,b] then u := b
uu := ['LAMBDA,vl,u]
- --------------------------> 11/28 drop COMP-TRAN, optimizations
T := [uu,m,oldE]
originalFun is ['WI,a,b] => markLambda(vl,a,m,T)
markLambda(vl,originalFun,m,T)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-24 20:11:44 +0000