a bug fix and a first pass at let-optimization

femtolisp/compiler.lsp

@@ -25,7 +25,7 @@
     :loadg :loada :loadc :loadg.l
     :setg  :seta  :setc  :setg.l
 
-    :closure :trycatch :argc :vargc]))
+    :closure :trycatch :argc :vargc :close :let]))
 
 (define arg-counts
   (table :eq?      2      :eqv?     2
@@ -121,7 +121,7 @@
 			 (set! i (+ i 1)))
 			
 			((:loada :seta :call :tcall :loadv :loadg :setg
-			  :list :+ :- :* :/ :vector :argc :vargc :loadi8)
+			  :list :+ :- :* :/ :vector :argc :vargc :loadi8 :let)
 			 (io.write bcode (uint8 nxt))
 			 (set! i (+ i 1)))
 			
@@ -328,6 +328,24 @@
 		     " arguments."))))
 
 (define (compile-app g env tail? x)
+  (let ((head (car x)))
+    (if (and (pair? head)
+	     (eq? (car head) 'lambda)
+	     (list? (cadr head)))
+	(compile-let  g env tail? x)
+	(compile-call g env tail? x))))
+
+(define (compile-let g env tail? x)
+  (let ((head (car x))
+	(args (cdr x)))
+    (unless (length= args (length (cadr head)))
+	    (error (string "apply: incorrect number of arguments to " head)))
+    (emit g :loadv (compile-f env head #t))
+    (let ((nargs (compile-arglist g env args)))
+      (emit g :close)
+      (emit g (if tail? :tcall :call) (+ 1 nargs)))))
+
+(define (compile-call g env tail? x)
   (let ((head  (car x)))
     (let ((head
 	   (if (and (symbol? head)
@@ -400,12 +418,12 @@
 		     (emit g :trycatch))
 	   (else   (compile-app g env tail? x))))))
 
-(define (compile-f env f)
+(define (compile-f env f . let?)
   (let ((g    (make-code-emitter))
 	(args (cadr f)))
-    (if (null? (lastcdr args))
+    (cond ((not (null? let?))     (emit g :let  (1+ (length args))))
-	(emit g :argc  (length args))
+	  ((null? (lastcdr args)) (emit g :argc (length args)))
-	(emit g :vargc (if (atom? args) 0 (length args))))
+	  (else  (emit g :vargc (if (atom? args) 0 (length args)))))
     (compile-in g (cons (to-proper args) env) #t (caddr f))
     (emit g :ret)
     `(compiled-lambda ,args ,(bytecode g))))
@@ -457,7 +475,7 @@
 		      (set! i (+ i 1)))
 
 		     ((:loada :seta :call :tcall :list :+ :- :* :/ :vector
-		       :argc :vargc :loadi8)
+		       :argc :vargc :loadi8 :let)
 		      (princ (number->string (aref code i)))
 		      (set! i (+ i 1)))
 

femtolisp/flisp.c

@@ -834,6 +834,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
                 penv++;
             }
             if (*penv == NIL) break;
+            assert(isvector(*penv));
             penv = &vector_elt(*penv, 0);
         }
         if (__unlikely((v = sym->binding) == UNBOUND))
@@ -922,12 +923,14 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
             if (*penv != NIL) {
                 // save temporary environment to the heap
                 lenv = penv;
+                assert(penv[envsz-1]==NIL || isvector(penv[envsz-1]));
                 pv = alloc_words(envsz + 1);
                 PUSH(tagptr(pv, TAG_VECTOR));
                 pv[0] = fixnum(envsz);
                 pv++;
                 while (envsz--)
                     *pv++ = *penv++;
+                assert(pv[-1]==NIL || isvector(pv[-1]));
                 // environment representation changed; install
                 // the new representation so everybody can see it
                 lenv[0] = NIL;
@@ -1390,6 +1393,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
             nargs = numval(v);
             bp = SP-nargs-2;
             f = Stack[bp+1];
+            penv = &Stack[bp+1];
             goto do_apply;
         case F_SPECIAL_APPLY:
             f = Stack[bp-4];
@@ -1473,6 +1477,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
         e = car_(f);
         if (selfevaluating(e)) { SP=saveSP; return(e); }
         PUSH(cdr_(f));                     // add closed environment
+        assert(Stack[SP-1]==NIL || isvector(Stack[SP-1]));
         Stack[bp+1] = car_(Stack[bp+1]);  // put lambda list
 
         if (noeval == 2) {
@@ -1490,6 +1495,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
                 for(i=0; i < (int)envsz; i++)
                     penv[i] = Stack[bp+1+i];
                 SP = (penv-Stack)+envsz;
+                assert(penv[envsz-1]==NIL || isvector(penv[envsz-1]));
                 goto eval_top;
             }
             else {
@@ -1580,7 +1586,7 @@ static value_t apply_cl(uint32_t nargs)
                 Stack[bp+i] = v;
                 Stack[bp+i+1] = Stack[bp+nargs];
                 Stack[bp+i+2] = Stack[bp+nargs+1];
-                pvals = &Stack[bp+nargs+1];
+                pvals = &Stack[bp+i+2];
             }
             else {
                 PUSH(NIL);
@@ -1591,6 +1597,14 @@ static value_t apply_cl(uint32_t nargs)
             }
             nargs = i+1;
             break;
+        case OP_LET:
+          ip++;
+          // last arg is closure environment to use
+          nargs--;
+          Stack[SP-2] = Stack[SP-1];
+          POPN(1);
+          pvals = &Stack[SP-1];
+          break;
         case OP_NOP: break;
         case OP_DUP: v = Stack[SP-1]; PUSH(v); break;
         case OP_POP: POPN(1); break;
@@ -2070,6 +2084,7 @@ static value_t apply_cl(uint32_t nargs)
             break;
 
         case OP_CLOSURE:
+        case OP_CLOSE:
             // build a closure (lambda args body . env)
             if (nargs > 0 && !captured) {
                 // save temporary environment to the heap
@@ -2089,6 +2104,7 @@ static value_t apply_cl(uint32_t nargs)
             else {
                 PUSH(Stack[bp]); // env has already been captured; share
             }
+            if (op == OP_CLOSURE) {
               c = (cons_t*)ptr(v=cons_reserve(3));
               e = cdr_(Stack[SP-2]);  // closure to copy
               //if (!iscons(e)) goto notpair;
@@ -2102,6 +2118,7 @@ static value_t apply_cl(uint32_t nargs)
               c->cdr = Stack[SP-1];  //env
               POPN(1);
               Stack[SP-1] = v;
+            }
             break;
 
         case OP_TRYCATCH:

femtolisp/opcodes.h

@@ -20,7 +20,7 @@ enum {
     OP_LOADV, OP_LOADVL, OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL,
     OP_SETG, OP_SETA, OP_SETC, OP_SETGL,
 
-    OP_CLOSURE, OP_TRYCATCH, OP_ARGC, OP_VARGC
+    OP_CLOSURE, OP_TRYCATCH, OP_ARGC, OP_VARGC, OP_CLOSE, OP_LET
 };
 
 #endif