From 43cb51f6406bc5f1a59a7c6137db5df44869490c Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Tue, 7 Apr 2009 15:55:13 +0000 Subject: [PATCH] replacing a recursive call with a goto; saves lots of stack space. --- femtolisp/flisp.c | 129 +++++++++++++++++++++++++--------------------- 1 file changed, 69 insertions(+), 60 deletions(-) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index a205d61..80cd9f2 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -660,8 +660,8 @@ static void list(value_t *pv, uint32_t nargs, value_t *plastcdr) #define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0)) #define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1)) -#define tail_eval(xpr) do { SP = saveSP; \ - if (selfevaluating(xpr)) { return (xpr); } \ +#define tail_eval(xpr) do { \ + if (selfevaluating(xpr)) { SP=saveSP; return (xpr); } \ else { e=(xpr); goto eval_top; } } while (0) /* eval a list of expressions, giving a list of the results */ @@ -767,24 +767,30 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) value_t f, v, *pv, *lenv; cons_t *c; symbol_t *sym; - uint32_t saveSP, envsz, nargs; + uint32_t saveSP, bp, envsz, nargs; int i, noeval=0; fixnum_t s, lo, hi; cvalue_t *cv; int64_t accum; + /* + ios_printf(ios_stdout, "eval "); print(ios_stdout, e, 0); + ios_printf(ios_stdout, " in "); print(ios_stdout, penv[0], 0); + ios_printf(ios_stdout, "\n"); + */ + saveSP = SP; eval_top: if (issymbol(e)) { sym = (symbol_t*)ptr(e); - if (sym->syntax == TAG_CONST) return sym->binding; + if (sym->syntax == TAG_CONST) { SP=saveSP; return sym->binding; } while (1) { v = *penv++; while (iscons(v)) { - if (car_(v)==e) return *penv; + if (car_(v)==e) { SP=saveSP; return *penv; } v = cdr_(v); penv++; } if (v != NIL) { - if (v == e) return *penv; // dotted list + if (v == e) { SP=saveSP; return *penv; } // dotted list penv++; } if (*penv == NIL) break; @@ -792,11 +798,15 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) } if (__unlikely((v = sym->binding) == UNBOUND)) raise(list2(UnboundError, e)); + SP = saveSP; return v; } - if (__unlikely(SP >= (N_STACK-MAX_ARGS-4))) - return new_stackseg(e, penv, tail); - saveSP = SP; + if (__unlikely(SP >= (N_STACK-MAX_ARGS-4))) { + v = new_stackseg(e, penv, tail); + SP = saveSP; + return v; + } + bp = SP; v = car_(e); PUSH(cdr_(e)); if (selfevaluating(v)) f=v; @@ -809,40 +819,40 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) else { noeval = 2; PUSH(f); - v = Stack[saveSP]; + v = Stack[bp]; goto move_args; } } else f = eval(v); PUSH(f); - v = Stack[saveSP]; + v = Stack[bp]; // evaluate argument list, placing arguments on stack while (iscons(v)) { - if (SP-saveSP-2 == MAX_ARGS) { - v = evlis(&Stack[saveSP], penv); + if (SP-bp-2 == MAX_ARGS) { + v = evlis(&Stack[bp], penv); PUSH(v); break; } v = car_(v); v = eval(v); PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); + v = Stack[bp] = cdr_(Stack[bp]); } do_apply: - nargs = SP - saveSP - 2; + nargs = SP - bp - 2; if (isbuiltinish(f)) { // handle builtin function apply_special: switch (uintval(f)) { // special forms case F_QUOTE: - if (__unlikely(!iscons(Stack[saveSP]))) + if (__unlikely(!iscons(Stack[bp]))) lerror(ArgError, "quote: expected argument"); - v = car_(Stack[saveSP]); + v = car_(Stack[bp]); break; case F_SETQ: - e = car(Stack[saveSP]); - v = car(cdr_(Stack[saveSP])); + e = car(Stack[bp]); + v = car(cdr_(Stack[bp])); v = eval(v); while (1) { f = *penv++; @@ -890,7 +900,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) PUSH(penv[1]); // env has already been captured; share } c = (cons_t*)ptr(v=cons_reserve(3)); - e = Stack[saveSP]; + e = Stack[bp]; if (!iscons(e)) goto notpair; c->car = LAMBDA; c->cdr = tagptr(c+1, TAG_CONS); c++; @@ -901,15 +911,15 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) c->cdr = Stack[SP-1]; //env break; case F_IF: - if (!iscons(Stack[saveSP])) goto notpair; - v = car_(Stack[saveSP]); + if (!iscons(Stack[bp])) goto notpair; + v = car_(Stack[bp]); if (eval(v) != FL_F) { - v = cdr_(Stack[saveSP]); + v = cdr_(Stack[bp]); if (!iscons(v)) goto notpair; v = car_(v); } else { - v = cdr_(Stack[saveSP]); + v = cdr_(Stack[bp]); if (!iscons(v)) goto notpair; if (!iscons(v=cdr_(v))) v = FL_F; // allow 2-arg form else v = car_(v); @@ -917,7 +927,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) tail_eval(v); break; case F_COND: - pv = &Stack[saveSP]; v = FL_F; + pv = &Stack[bp]; v = FL_F; while (iscons(*pv)) { c = tocons(car_(*pv), "cond"); v = c->car; @@ -941,7 +951,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) } break; case F_AND: - pv = &Stack[saveSP]; v = FL_T; + pv = &Stack[bp]; v = FL_T; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { if ((v=eval(car_(*pv))) == FL_F) { @@ -953,7 +963,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) } break; case F_OR: - pv = &Stack[saveSP]; v = FL_F; + pv = &Stack[bp]; v = FL_F; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { if ((v=eval(car_(*pv))) != FL_F) { @@ -965,11 +975,11 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) } break; case F_WHILE: - PUSH(cdr(Stack[saveSP])); + PUSH(cdr(Stack[bp])); lenv = &Stack[SP-1]; PUSH(*lenv); - Stack[saveSP] = car_(Stack[saveSP]); - value_t *cond = &Stack[saveSP]; + Stack[bp] = car_(Stack[bp]); + value_t *cond = &Stack[bp]; PUSH(FL_F); pv = &Stack[SP-1]; while (eval(*cond) != FL_F) { @@ -983,7 +993,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_BEGIN: // return last arg - pv = &Stack[saveSP]; + pv = &Stack[bp]; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { v = car_(*pv); @@ -996,7 +1006,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_PROG1: // return first arg - pv = &Stack[saveSP]; + pv = &Stack[bp]; if (__unlikely(!iscons(*pv))) lerror(ArgError, "prog1: too few arguments"); PUSH(eval(car_(*pv))); @@ -1008,7 +1018,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) v = POP(); break; case F_TRYCATCH: - v = do_trycatch(car(Stack[saveSP]), penv); + v = do_trycatch(car(Stack[bp]), penv); break; // ordinary functions @@ -1033,8 +1043,8 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_LIST: if (nargs) { - Stack[saveSP] = v; - list(&v, nargs, &Stack[saveSP]); + Stack[bp] = v; + list(&v, nargs, &Stack[bp]); } // else v is already set to the final cdr, which is the result break; @@ -1065,7 +1075,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) } else i = 0; v = alloc_vector(nargs+i, 0); - memcpy(&vector_elt(v,0), &Stack[saveSP+2], nargs*sizeof(value_t)); + memcpy(&vector_elt(v,0), &Stack[bp+2], nargs*sizeof(value_t)); if (i > 0) { e = Stack[SP-1]; while (iscons(e)) { @@ -1185,7 +1195,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_ADD: s = 0; - i = saveSP+2; + i = bp+2; if (nargs > MAX_ARGS) goto add_ovf; for (; i < (int)SP; i++) { if (__likely(isfixnum(Stack[i]))) { @@ -1206,7 +1216,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_SUB: if (__unlikely(nargs < 1)) lerror(ArgError, "-: too few arguments"); - i = saveSP+2; + i = bp+2; if (nargs == 1) { if (__likely(isfixnum(Stack[i]))) v = fixnum(-numval(Stack[i])); @@ -1239,7 +1249,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_MUL: accum = 1; - i = saveSP+2; + i = bp+2; if (nargs > MAX_ARGS) goto mul_ovf; for (; i < (int)SP; i++) { if (__likely(isfixnum(Stack[i]))) { @@ -1259,7 +1269,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) break; case F_DIV: if (__unlikely(nargs < 1)) lerror(ArgError, "/: too few arguments"); - i = saveSP+2; + i = bp+2; if (nargs == 1) { v = fl_div2(fixnum(1), Stack[i]); } @@ -1361,20 +1371,20 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) } break; case F_SPECIAL_APPLY: - f = Stack[saveSP-4]; - v = Stack[saveSP-3]; + f = Stack[bp-4]; + v = Stack[bp-3]; PUSH(f); PUSH(v); nargs = 2; // falls through!! case F_APPLY: argcount("apply", nargs, 2); - v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist - f = Stack[saveSP+1] = Stack[SP-2]; // first arg is new function + v = Stack[bp] = Stack[SP-1]; // second arg is new arglist + f = Stack[bp+1] = Stack[SP-2]; // first arg is new function POPN(2); // pop apply's args move_args: while (iscons(v)) { - if (SP-saveSP-2 == MAX_ARGS) { + if (SP-bp-2 == MAX_ARGS) { PUSH(v); break; } @@ -1388,15 +1398,15 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) goto apply_type_error; default: // function pointer tagged as a builtin - v = ((builtin_t)ptr(f))(&Stack[saveSP+2], nargs); + v = ((builtin_t)ptr(f))(&Stack[bp+2], nargs); } SP = saveSP; return v; } if (__likely(iscons(f))) { // apply lambda expression - f = Stack[saveSP+1]; - f = Stack[saveSP+1] = cdr_(f); + f = Stack[bp+1]; + f = Stack[bp+1] = cdr_(f); if (!iscons(f)) goto notpair; v = car_(f); // arglist i = nargs; @@ -1424,20 +1434,19 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) PUSH(NIL); } } - f = cdr_(Stack[saveSP+1]); + f = cdr_(Stack[bp+1]); if (!iscons(f)) goto notpair; e = car_(f); if (selfevaluating(e)) { SP=saveSP; return(e); } PUSH(cdr_(f)); // add closed environment - Stack[saveSP+1] = car_(Stack[saveSP+1]); // put lambda list - envsz = SP - saveSP - 1; + Stack[bp+1] = car_(Stack[bp+1]); // put lambda list + envsz = SP - bp - 1; if (noeval == 2) { // macro: evaluate body in lambda environment - Stack[saveSP] = fixnum(envsz); - e = eval_sexpr(e, &Stack[saveSP+1], 1); - SP = saveSP; - if (selfevaluating(e)) return(e); + Stack[bp] = fixnum(envsz); + e = eval_sexpr(e, &Stack[bp+1], 1); + if (selfevaluating(e)) { SP=saveSP; return(e); } noeval = 0; // macro: evaluate expansion in calling environment goto eval_top; @@ -1447,15 +1456,15 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) // ok to overwrite environment penv[-1] = fixnum(envsz); for(i=0; i < (int)envsz; i++) - penv[i] = Stack[saveSP+1+i]; + penv[i] = Stack[bp+1+i]; SP = (penv-Stack)+envsz; goto eval_top; } else { - Stack[saveSP] = fixnum(envsz); - v = eval_sexpr(e, &Stack[saveSP+1], 1); - SP = saveSP; - return v; + Stack[bp] = fixnum(envsz); + penv = &Stack[bp+1]; + tail = 1; + goto eval_top; } } // not reached