ref: 60644c760ee8fc20fc19bbdde40d3ba09fa83385
parent: 180b05fa8e5ce0dd7a172c3a5cfad3fcec8f7073
author: JeffBezanson <[email protected]>
date: Sat Jul 26 00:03:48 EDT 2008
made apply() entry point more efficient (now non-consing) added selfevaluating(v) predicate
--- 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 value_t special_apply_form;
+
void gc(int mustgrow)
{static int grew = 0;
@@ -457,6 +459,7 @@
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 @@
{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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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++) {--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -50,6 +50,7 @@
#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 @@
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,
--- 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")
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -487,7 +487,7 @@
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:
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -109,7 +109,7 @@
- (*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: