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

some optimizations

This commit is contained in:
JeffBezanson 2009-04-16 14:21:16 +00:00
parent ad4a086790
commit 0a3590aa01
1 changed files with 37 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
femtolisp/flisp.c
View File

@ -771,6 +771,7 @@ static value_t do_trycatch(value_t expr, value_t *penv, uint32_t envsz)
static value_t do_trycatch2() static value_t do_trycatch2()
{ {
uint32_t saveSP = SP;
value_t v; value_t v;
value_t thunk = Stack[SP-2]; value_t thunk = Stack[SP-2];
Stack[SP-2] = Stack[SP-1]; Stack[SP-2] = Stack[SP-1];
@ -783,6 +784,7 @@ static value_t do_trycatch2()
Stack[SP-1] = lasterror; Stack[SP-1] = lasterror;
v = apply_cl(1); v = apply_cl(1);
} }
SP = saveSP;
return v; return v;
} }
@ -1426,7 +1428,9 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
assert(SP > bp+1); assert(SP > bp+1);
if (__likely(iscons(f))) { if (__likely(iscons(f))) {
if (car_(f) == COMPILEDLAMBDA) { if (car_(f) == COMPILEDLAMBDA) {
i = SP;
e = apply_cl(nargs); e = apply_cl(nargs);
SP = i;
if (noeval == 2) { if (noeval == 2) {
if (selfevaluating(e)) { SP=saveSP; return(e); } if (selfevaluating(e)) { SP=saveSP; return(e); }
noeval = 0; noeval = 0;
@ -1510,12 +1514,12 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
- provide arg count - provide arg count
- respect tail position - respect tail position
- call correct entry point (either eval_sexpr or apply_cl) - call correct entry point (either eval_sexpr or apply_cl)
- restore SP
callee's responsibility: callee's responsibility:
- check arg counts - check arg counts
- allocate vararg array - allocate vararg array
- push closed env, set up new environment - push closed env, set up new environment
- restore SP
** need 'copyenv' instruction that moves env to heap, installs ** need 'copyenv' instruction that moves env to heap, installs
heap version as the current env, and pushes the result vector. heap version as the current env, and pushes the result vector.
@ -1525,34 +1529,31 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
*/ */
static value_t apply_cl(uint32_t nargs) static value_t apply_cl(uint32_t nargs)
{ {
uint32_t i, n, ip, bp, envsz, saveSP=SP; uint32_t i, n, ip, bp, envsz, captured;
fixnum_t s, lo, hi; fixnum_t s, lo, hi;
int64_t accum; int64_t accum;
uint8_t op, *code; uint8_t op, *code;
value_t func, v, bcode, x, e, ftl; value_t func, v, bcode, x, e;
value_t *penv, *pvals, *lenv, *pv; value_t *pvals, *lenv, *pv;
symbol_t *sym; symbol_t *sym;
cons_t *c; cons_t *c;
apply_cl_top: apply_cl_top:
captured = 0;
func = Stack[SP-nargs-1]; func = Stack[SP-nargs-1];
assert(iscons(func)); assert(iscons(func));
assert(iscons(cdr_(func))); assert(iscons(cdr_(func)));
assert(iscons(cdr_(cdr_(func)))); assert(iscons(cdr_(cdr_(func))));
ftl = cdr_(cdr_(func)); x = cdr_(cdr_(func));
bcode = car_(ftl); bcode = car_(x);
code = cv_data((cvalue_t*)ptr(car_(bcode))); code = cv_data((cvalue_t*)ptr(car_(bcode)));
assert(!ismanaged((uptrint_t)code)); assert(!ismanaged((uptrint_t)code));
if (nargs < code[1]) if (nargs < code[1])
lerror(ArgError, "apply: too few arguments"); lerror(ArgError, "apply: too few arguments");
bp = SP-nargs; bp = SP-nargs;
x = cdr_(ftl); // cloenv x = cdr_(x); // cloenv
Stack[bp-1] = car_(cdr_(func)); // lambda list
penv = &Stack[bp-1];
PUSH(x); PUSH(x);
// must keep a reference to the bcode object while executing it
PUSH(bcode);
PUSH(cdr_(bcode)); PUSH(cdr_(bcode));
pvals = &Stack[SP-1]; pvals = &Stack[SP-1];
@ -1579,15 +1580,13 @@ 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];
Stack[bp+i+3] = Stack[bp+nargs+2]; pvals = &Stack[bp+nargs+1];
pvals = &Stack[bp+nargs+2];
} }
else { else {
PUSH(NIL); PUSH(NIL);
Stack[SP-1] = Stack[SP-2]; Stack[SP-1] = Stack[SP-2];
Stack[SP-2] = Stack[SP-3]; Stack[SP-2] = Stack[SP-3];
Stack[SP-3] = Stack[SP-4]; Stack[SP-3] = NIL;
Stack[SP-4] = NIL;
pvals = &Stack[SP-1]; pvals = &Stack[SP-1];
} }
nargs = i+1; nargs = i+1;
@ -1656,7 +1655,7 @@ static value_t apply_cl(uint32_t nargs)
if (v != FL_F) ip = *(uint32_t*)&code[ip]; if (v != FL_F) ip = *(uint32_t*)&code[ip];
else ip += 4; else ip += 4;
break; break;
case OP_RET: v = POP(); SP = saveSP; return v; case OP_RET: v = POP(); return v;
case OP_EQ: case OP_EQ:
Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F); Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
@ -1962,10 +1961,12 @@ static value_t apply_cl(uint32_t nargs)
//f = Stack[SP-1]; //f = Stack[SP-1];
v = FL_F; v = FL_F;
SP += 2; SP += 2;
i = SP;
for(s=lo; s <= hi; s++) { for(s=lo; s <= hi; s++) {
Stack[SP-2] = Stack[SP-3]; Stack[SP-2] = Stack[SP-3];
Stack[SP-1] = fixnum(s); Stack[SP-1] = fixnum(s);
v = apply_cl(1); v = apply_cl(1);
SP = i;
} }
POPN(4); POPN(4);
Stack[SP-1] = v; Stack[SP-1] = v;
@ -2017,10 +2018,11 @@ static value_t apply_cl(uint32_t nargs)
case OP_LOADA: case OP_LOADA:
assert(nargs > 0); assert(nargs > 0);
i = code[ip++]; i = code[ip++];
if (penv[0] == NIL) { if (captured) {
assert(isvector(penv[1])); x = Stack[bp];
assert(i+1 < vector_size(penv[1])); assert(isvector(x));
v = vector_elt(penv[1], i+1); assert(i < vector_size(x));
v = vector_elt(x, i);
} }
else { else {
assert(bp+i < SP); assert(bp+i < SP);
@ -2032,10 +2034,11 @@ static value_t apply_cl(uint32_t nargs)
assert(nargs > 0); assert(nargs > 0);
v = Stack[SP-1]; v = Stack[SP-1];
i = code[ip++]; i = code[ip++];
if (penv[0] == NIL) { if (captured) {
assert(isvector(penv[1])); x = Stack[bp];
assert(i+1 < vector_size(penv[1])); assert(isvector(x));
vector_elt(penv[1], i+1) = v; assert(i < vector_size(x));
vector_elt(x, i) = v;
} }
else { else {
assert(bp+i < SP); assert(bp+i < SP);
@ -2045,16 +2048,16 @@ static value_t apply_cl(uint32_t nargs)
case OP_LOADC: case OP_LOADC:
case OP_SETC: case OP_SETC:
s = code[ip++]; s = code[ip++];
i = code[ip++]+1; i = code[ip++];
if (penv[0]==NIL) { if (captured) {
if (nargs > 0) { if (nargs > 0) {
// current frame has been captured // current frame has been captured
s++; s++;
} }
v = penv[1]; v = Stack[bp];
} }
else { else {
v = penv[nargs+1]; v = Stack[bp+nargs];
} }
while (s--) while (s--)
v = vector_elt(v, vector_size(v)-1); v = vector_elt(v, vector_size(v)-1);
@ -2068,10 +2071,10 @@ static value_t apply_cl(uint32_t nargs)
case OP_CLOSURE: case OP_CLOSURE:
// build a closure (lambda args body . env) // build a closure (lambda args body . env)
if (penv[0] != NIL) { if (nargs > 0 && !captured) {
// save temporary environment to the heap // save temporary environment to the heap
lenv = penv; lenv = &Stack[bp];
envsz = nargs+2; envsz = nargs+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);
@ -2080,11 +2083,11 @@ static value_t apply_cl(uint32_t nargs)
*pv++ = *lenv++; *pv++ = *lenv++;
// environment representation changed; install // environment representation changed; install
// the new representation so everybody can see it // the new representation so everybody can see it
penv[0] = NIL; captured = 1;
penv[1] = Stack[SP-1]; Stack[bp] = Stack[SP-1];
} }
else { else {
PUSH(penv[1]); // env has already been captured; share PUSH(Stack[bp]); // env has already been captured; share
} }
c = (cons_t*)ptr(v=cons_reserve(3)); c = (cons_t*)ptr(v=cons_reserve(3));
e = cdr_(Stack[SP-2]); // closure to copy e = cdr_(Stack[SP-2]); // closure to copy