ref: 94814a2e3472dbfdecc179f6c24658591fd168a6
parent: 0a3590aa01c033b2e03a0e83336842ecce76aae5
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Thu Apr 16 17:20:15 EDT 2009
a bug fix and a first pass at let-optimization
--- a/femtolisp/compiler.lsp
+++ b/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)))
@@ -326,8 +326,26 @@
(if (= count 1)
" argument."
" 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))
- (emit g :argc (length args))
- (emit g :vargc (if (atom? args) 0 (length args))))
+ (cond ((not (null? let?)) (emit g :let (1+ (length args))))
+ ((null? (lastcdr args)) (emit g :argc (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)))
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -834,6 +834,7 @@
penv++;
}
if (*penv == NIL) break;
+ assert(isvector(*penv));
penv = &vector_elt(*penv, 0);
}
if (__unlikely((v = sym->binding) == UNBOUND))
@@ -922,6 +923,7 @@
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);
@@ -928,6 +930,7 @@
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 @@
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 @@
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 @@
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 @@
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 @@
}
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 @@
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,19 +2104,21 @@
else {PUSH(Stack[bp]); // env has already been captured; share
}
- c = (cons_t*)ptr(v=cons_reserve(3));
- e = cdr_(Stack[SP-2]); // closure to copy
- //if (!iscons(e)) goto notpair;
- c->car = COMPILEDLAMBDA;
- c->cdr = tagptr(c+1, TAG_CONS); c++;
- c->car = car_(e); //argsyms
- c->cdr = tagptr(c+1, TAG_CONS); c++;
- e = cdr_(e);
- //if (!iscons(e=cdr_(e))) goto notpair;
- c->car = car_(e); //body
- c->cdr = Stack[SP-1]; //env
- POPN(1);
- Stack[SP-1] = v;
+ 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;
+ c->car = COMPILEDLAMBDA;
+ c->cdr = tagptr(c+1, TAG_CONS); c++;
+ c->car = car_(e); //argsyms
+ c->cdr = tagptr(c+1, TAG_CONS); c++;
+ e = cdr_(e);
+ //if (!iscons(e=cdr_(e))) goto notpair;
+ c->car = car_(e); //body
+ c->cdr = Stack[SP-1]; //env
+ POPN(1);
+ Stack[SP-1] = v;
+ }
break;
case OP_TRYCATCH:
--- a/femtolisp/opcodes.h
+++ b/femtolisp/opcodes.h
@@ -20,7 +20,7 @@
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