made apply() entry point more efficient (now non-consing)

added selfevaluating(v) predicate

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++) {

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,

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")

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:

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: