lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

a bug fix and a first pass at let-optimization

This commit is contained in:
JeffBezanson 2009-04-16 21:20:15 +00:00
parent 0a3590aa01
commit 94814a2e34
3 changed files with 58 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
femtolisp/compiler.lsp
View File

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

45
femtolisp/flisp.c
View File

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

2
femtolisp/opcodes.h
View File

@ -20,7 +20,7 @@ enum {
OP_LOADV, OP_LOADVL, OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL, OP_LOADV, OP_LOADVL, OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL,
OP_SETG, OP_SETA, OP_SETC, OP_SETGL, 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 #endif