From 94814a2e3472dbfdecc179f6c24658591fd168a6 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Thu, 16 Apr 2009 21:20:15 +0000 Subject: [PATCH] a bug fix and a first pass at let-optimization --- femtolisp/compiler.lsp | 34 +++++++++++++++++++++++-------- femtolisp/flisp.c | 45 +++++++++++++++++++++++++++++------------- femtolisp/opcodes.h | 2 +- 3 files changed, 58 insertions(+), 23 deletions(-) diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 65b49e0..4b730ed 100644 --- 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))) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index a3d96ba..2b1bbdd 100644 --- a/femtolisp/flisp.c +++ b/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,19 +2104,21 @@ static value_t apply_cl(uint32_t nargs) 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: diff --git a/femtolisp/opcodes.h b/femtolisp/opcodes.h index e53297a..379d87b 100644 --- a/femtolisp/opcodes.h +++ b/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