From 60644c760ee8fc20fc19bbdde40d3ba09fa83385 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Sat, 26 Jul 2008 04:03:48 +0000 Subject: [PATCH] made apply() entry point more efficient (now non-consing) added selfevaluating(v) predicate --- femtolisp/flisp.c | 59 ++++++++++++++++++++-------------------------- femtolisp/flisp.h | 3 ++- femtolisp/perf.lsp | 4 ++++ femtolisp/read.c | 2 +- femtolisp/todo | 2 +- 5 files changed, 34 insertions(+), 36 deletions(-) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 09b663d..9eabe18 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -69,7 +69,7 @@ static char *builtin_names[] = { "quote", "cond", "if", "and", "or", "while", "lambda", - "trycatch", "progn", + "trycatch", "%apply", "progn", "eq", "atom", "not", "symbolp", "numberp", "boundp", "consp", "builtinp", "vectorp", "fixnump", "equal", @@ -435,6 +435,8 @@ static void trace_globals(symbol_t *root) } } +static value_t special_apply_form; + void gc(int mustgrow) { static int grew = 0; @@ -457,6 +459,7 @@ void gc(int mustgrow) rs = rs->prev; } lasterror = relocate(lasterror); + special_apply_form = relocate(special_apply_form); #ifdef VERBOSEGC printf("gc found %d/%d live conses\n", (curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t)); @@ -494,22 +497,7 @@ value_t apply(value_t f, value_t l) { PUSH(f); PUSH(l); - value_t e = cons_reserve(5); - value_t x = e; - car_(e) = builtin(F_APPLY); - cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e); - // TODO: consider quoting this if it's a lambda expression - car_(e) = Stack[SP-2]; - cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e); - car_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); - cdr_(e) = NIL; - e = car_(e); - car_(e) = QUOTE; - cdr_(e) = tagptr(((cons_t*)ptr(e))+1, TAG_CONS); e = cdr_(e); - car_(e) = Stack[SP-1]; - cdr_(e) = NIL; - POPN(2); - return toplevel_eval(x); + return toplevel_eval(special_apply_form); } value_t listn(size_t n, ...) @@ -608,10 +596,10 @@ static value_t assoc(value_t item, value_t v) return NIL; } -#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0)) -#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1)) +#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 (tag(xpr)<0x2) { return (xpr); } \ + if (selfevaluating(xpr)) { return (xpr); } \ else { e=(xpr); goto eval_top; } } while (0) static value_t do_trycatch(value_t expr, uint32_t penv) @@ -692,7 +680,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) saveSP = SP; v = car_(e); PUSH(cdr_(e)); - if (tag(v)<0x2) f=v; + if (selfevaluating(v)) f=v; else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax)) { // handle special syntax forms if (isspecial(f)) @@ -1127,7 +1115,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) case F_EVAL: argcount("eval", nargs, 1); v = Stack[SP-1]; - if (tag(v)<0x2) { SP=saveSP; return v; } + if (selfevaluating(v)) { SP=saveSP; return v; } if (tail) { Stack[penv-1] = fixnum(2); Stack[penv] = NIL; @@ -1156,6 +1144,12 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) argcount("assoc", nargs, 2); v = assoc(Stack[SP-2], Stack[SP-1]); break; + case F_SPECIAL_APPLY: + v = Stack[saveSP-4]; + f = Stack[saveSP-5]; + PUSH(f); + PUSH(v); + nargs = 2; case F_APPLY: argcount("apply", nargs, 2); v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist @@ -1251,26 +1245,23 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) if (iscons(*argsyms)) { lerror(ArgError, "apply: too few arguments"); } - *argsyms = car_(Stack[saveSP+1]); f = cdr_(Stack[saveSP+1]); - PUSH(cdr(f)); - e = car_(f); + e = car(f); + if (selfevaluating(e)) { SP=saveSP; return(e); } + PUSH(cdr_(f)); // add closed environment + *argsyms = car_(Stack[saveSP+1]); // put lambda list if (noeval == 2) { // macro: evaluate body in lambda environment - if (tag(e)<0x2) ; - else { - Stack[saveSP+1] = fixnum(SP-saveSP-2); - e = eval_sexpr(e, saveSP+2, 1); - } + Stack[saveSP+1] = fixnum(SP-saveSP-2); + e = eval_sexpr(e, saveSP+2, 1); SP = saveSP; - if (tag(e)<0x2) return(e); + if (selfevaluating(e)) return(e); noeval = 0; // macro: evaluate expansion in calling environment goto eval_top; } else { - if (tag(e)<0x2) { SP=saveSP; return(e); } envsz = SP - saveSP - 2; if (tail) { noeval = 0; @@ -1337,9 +1328,11 @@ void lisp_init(void) builtinsym = symbol("builtin"); lasterror = NIL; lerrorbuf[0] = '\0'; + special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL); i = 0; while (isspecial(builtin(i))) { - ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i); + if (i != F_SPECIAL_APPLY) + ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i); i++; } for (; i < N_BUILTINS; i++) { diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 8df9641..038f272 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -50,6 +50,7 @@ typedef struct _symbol_t { #define isvectorish(x) ((tag(x) == TAG_BUILTIN) && uintval(x) > N_BUILTINS) #define isvector(x) (isvectorish(x) && !(((value_t*)ptr(x))[0] & 0x2)) #define iscvalue(x) (isvectorish(x) && (((value_t*)ptr(x))[0] & 0x2)) +#define selfevaluating(x) (tag(x)<0x2) // distinguish a vector from a cvalue #define discriminateAsVector(x) (!(((value_t*)ptr(x))[0] & 0x2)) #define vector_size(v) (((size_t*)ptr(v))[0]>>2) @@ -78,7 +79,7 @@ extern u_int32_t SP; enum { // special forms F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, - F_TRYCATCH, F_PROGN, + F_TRYCATCH, F_SPECIAL_APPLY, F_PROGN, // functions F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP, F_EQUAL, diff --git a/femtolisp/perf.lsp b/femtolisp/perf.lsp index 885d02b..f009163 100644 --- a/femtolisp/perf.lsp +++ b/femtolisp/perf.lsp @@ -15,6 +15,10 @@ (princ "mexpand: ") (time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2)))) +(princ "append: ") +(setq L (map-int (lambda (x) (map-int identity 20)) 20)) +(time (dotimes (n 1000) (apply append L))) + (path.cwd "ast") (princ "p-lambda: ") (load "rpasses.lsp") diff --git a/femtolisp/read.c b/femtolisp/read.c index cd2a014..8ea4176 100644 --- a/femtolisp/read.c +++ b/femtolisp/read.c @@ -487,7 +487,7 @@ static value_t do_read_sexpr(FILE *f, value_t label) PUSH(NIL); read_list(f, &Stack[SP-1], UNBOUND); v = POP(); - return apply(sym, v); + return apply(symbol_value(sym), v); case TOK_OPENB: return read_vector(f, label, TOK_CLOSEB); case TOK_SHARPOPEN: diff --git a/femtolisp/todo b/femtolisp/todo index 825c858..d0adae1 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -109,7 +109,7 @@ target without moving away from s-expressions: - (*global* . a) ; special form, don't look in local env first - (*local* . 2) ; direct stackframe access for internal use: -- a special version of apply that takes arguments on the stack, to avoid +* a special version of apply that takes arguments on the stack, to avoid consing when implementing "call-with" style primitives like trycatch, hashtable-foreach, or the fl_apply API - try this environment representation: