From 43e8d1fbf0ae895bb09b2beb89b31f1f7440a8e2 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Wed, 1 Apr 2009 04:31:49 +0000 Subject: [PATCH] adding the ability to heap-allocate extentions to the value stack, so recursion depth is limited only by the process stack limit. reorganizing evaluator so the same code is used for evaluating and pushing arguments for both builtin functions and lambdas. for now this is slower, but it was done in preparation for Things To Come. adding list-head implementing the calling convention for long argument lists in bytecode compiler. arguments are broken down into a nest of list and nconc calls. also implementing vararg builtins. --- femtolisp/compiler.lsp | 59 ++++++-- femtolisp/flisp.c | 322 +++++++++++++++++++++-------------------- femtolisp/flisp.h | 2 +- femtolisp/system.lsp | 7 +- femtolisp/todo | 4 +- femtolisp/torture.scm | 19 +++ 6 files changed, 242 insertions(+), 171 deletions(-) create mode 100644 femtolisp/torture.scm diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 28aa6cc..076c05d 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -104,7 +104,8 @@ (io.write bcode (uint32 nxt)) (set! i (+ i 1))) - ((:loada :seta :call :loadv :loadg :setg :popn) + ((:loada :seta :call :loadv :loadg :setg :popn + :list :+ :- :* :/ :vector) (io.write bcode (uint8 nxt)) (set! i (+ i 1))) @@ -254,15 +255,45 @@ (compile-or g (cdr forms) env) (mark-label g end))))) -;; TODO support long argument lists -(define (compile-args g lst env) +(define MAX_ARGS 127) + +(define (list-part- l n i subl acc) + (cond ((atom? l) (if (> i 0) + (cons (nreverse subl) acc) + acc)) + ((>= i n) (list-part- l n 0 () (cons (nreverse subl) acc))) + (else (list-part- (cdr l) n (+ 1 i) (cons (car l) subl) acc)))) +(define (list-partition l n) + (if (<= n 0) + (error "list-partition: invalid count") + (nreverse (list-part- l n 0 () ())))) + +(define (length> lst n) + (cond ((< n 0) lst) + ((= n 0) (and (pair? lst) lst)) + ((null? lst) (< n 0)) + (else (length> (cdr lst) (- n 1))))) + +(define (just-compile-args g lst env) (for-each (lambda (a) (compile-in g a env)) lst)) +(define (compile-arglist g lst env) + (let ((argtail (length> lst MAX_ARGS))) + (if argtail + (begin (just-compile-args g (list-head lst MAX_ARGS) env) + (let ((rest + (cons nconc + (map (lambda (l) (cons list l)) + (list-partition argtail MAX_ARGS))))) + (compile-in g rest env)) + (+ MAX_ARGS 1)) + (begin (just-compile-args g lst env) + (length lst))))) + (define (compile-app g x env) - (let ((head (car x)) - (nargs (length (cdr x)))) + (let ((head (car x))) (let ((head (if (and (symbol? head) (not (in-env? head env)) @@ -275,10 +306,12 @@ (builtin->instruction head)))) (if (not b) (compile-in g head env)) - (compile-args g (cdr x) env) - (if b ;; TODO check arg count - (emit g b) - (emit g :call nargs)))))) + (let ((nargs (compile-arglist g (cdr x) env))) + (if b ;; TODO check arg count + (if (memq b '(:list :+ :- :* :/ :vector)) + (emit g b nargs) + (emit g b)) + (emit g :call nargs))))))) (define (compile-in g x env) (cond ((symbol? x) (compile-sym g x env [:loada :loadc :loadg])) @@ -300,7 +333,7 @@ (emit g :closure))) (and (compile-and g (cdr x) env)) (or (compile-or g (cdr x) env)) - (while (compile-while g (car x) (cadr x) env)) + (while (compile-while g (cadr x) (caddr x) env)) (set! (compile-in g (caddr x) env) (compile-sym g (cadr x) env [:seta :setc :setg])) (trycatch (compile-in g `(lambda () ,(cadr x)) env) @@ -315,7 +348,7 @@ `(compiled-lambda ,(cadr f) ,(bytecode g)))) (define (compile x) - (compile-in (make-code-emitter) x ())) + (bytecode (compile-in (make-code-emitter) x ()))) (define (ref-uint32-LE a i) (+ (ash (aref a (+ i 0)) 0) @@ -359,7 +392,7 @@ (print-val (aref vals (aref code i))) (set! i (+ i 1))) - ((:loada :seta :call :popn) + ((:loada :seta :call :popn :list :+ :- :* :/ :vector) (princ (number->string (aref code i))) (set! i (+ i 1))) @@ -379,6 +412,6 @@ (else #f)))))))) -(define (disassemble b) (disassemble- b 0)) +(define (disassemble b) (disassemble- b 0) (newline)) #t diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 1f1883d..6207025 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -73,10 +73,20 @@ static char *builtin_names[] = "vector", "aref", "aset!", "length", "for", "", "", "" }; -#define N_STACK 131072 -value_t Stack[N_STACK]; +#define N_STACK 262144 +value_t StaticStack[N_STACK]; +value_t *Stack = StaticStack; uint32_t SP = 0; +typedef struct _stackseg_t { + value_t *Stack; + uint32_t SP; + struct _stackseg_t *prev; +} stackseg_t; + +stackseg_t stackseg0 = { StaticStack, 0, NULL }; +stackseg_t *current_stack_seg = &stackseg0; + value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH; value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; @@ -85,7 +95,7 @@ value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym; value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym; -static value_t eval_sexpr(value_t e, uint32_t penv, int tail); +static value_t eval_sexpr(value_t e, value_t *penv, int tail); static value_t *alloc_words(int n); static value_t relocate(value_t v); @@ -465,12 +475,18 @@ void gc(int mustgrow) void *temp; uint32_t i; readstate_t *rs; + stackseg_t *ss; curheap = tospace; lim = curheap+heapsize-sizeof(cons_t); - for (i=0; i < SP; i++) - Stack[i] = relocate(Stack[i]); + ss = current_stack_seg; + ss->SP = SP; + while (ss) { + for (i=0; i < ss->SP; i++) + ss->Stack[i] = relocate(ss->Stack[i]); + ss = ss->prev; + } trace_globals(symtab); relocate_typetable(); rs = readstate; @@ -640,7 +656,6 @@ static void list(value_t *pv, uint32_t nargs, value_t *plastcdr) (c-2)->cdr = (c-1)->car; else (c-1)->cdr = *plastcdr; - POPN(nargs); } #define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0)) @@ -650,7 +665,7 @@ static void list(value_t *pv, uint32_t nargs, value_t *plastcdr) else { e=(xpr); goto eval_top; } } while (0) /* eval a list of expressions, giving a list of the results */ -static value_t evlis(value_t *pv, uint32_t penv) +static value_t evlis(value_t *pv, value_t *penv) { PUSH(NIL); PUSH(NIL); @@ -675,7 +690,42 @@ static value_t evlis(value_t *pv, uint32_t penv) return POP(); } -static value_t do_trycatch(value_t expr, uint32_t penv) +/* + If we start to run out of space on the lisp value stack, we allocate + a new stack array and put it on the top of the chain. The new stack + is active until this function returns. Any return past this function + must free the new segment. +*/ +static value_t new_stackseg(value_t e, value_t *penv, int tail) +{ + stackseg_t s; + + s.prev = current_stack_seg; + s.Stack = (value_t*)malloc(N_STACK * sizeof(value_t)); + if (s.Stack == NULL) + lerror(MemoryError, "eval: stack overflow"); + current_stack_seg->SP = SP; + current_stack_seg = &s; + SP = 0; + Stack = s.Stack; + value_t v = NIL; + int err = 0; + FL_TRY { + v = eval_sexpr(e, penv, tail); + } + FL_CATCH { + err = 1; + v = lasterror; + } + free(s.Stack); + current_stack_seg = s.prev; + SP = current_stack_seg->SP; + Stack = current_stack_seg->Stack; + if (err) raise(v); + return v; +} + +static value_t do_trycatch(value_t expr, value_t *penv) { value_t v; @@ -710,18 +760,14 @@ static value_t do_trycatch(value_t expr, uint32_t penv) of the stack from LL through CLO. There might be zero values, in which case LL is NIL. - Stack[penv-1] is the size of the whole environment (as a fixnum) - - if tail==1, you are allowed (indeed encouraged) to overwrite this - environment, otherwise you have to put any new environment on the top - of the stack. + penv[-1] tells you the environment size, from LL through CLO, as a fixnum. */ -static value_t eval_sexpr(value_t e, uint32_t penv, int tail) +static value_t eval_sexpr(value_t e, value_t *penv, int tail) { - value_t f, v, *pv, *argsyms, *body; + value_t f, v, *pv, *lenv; cons_t *c; symbol_t *sym; - uint32_t saveSP, envsz, lenv, nargs; + uint32_t saveSP, envsz, nargs; int i, noeval=0; fixnum_t s, lo, hi; cvalue_t *cv; @@ -731,26 +777,25 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) if (issymbol(e)) { sym = (symbol_t*)ptr(e); if (sym->syntax == TAG_CONST) return sym->binding; - pv = &Stack[penv]; while (1) { - v = *pv++; + v = *penv++; while (iscons(v)) { - if (car_(v)==e) return *pv; - v = cdr_(v); pv++; + if (car_(v)==e) return *penv; + v = cdr_(v); penv++; } if (v != NIL) { - if (v == e) return *pv; // dotted list - pv++; + if (v == e) return *penv; // dotted list + penv++; } - if (*pv == NIL) break; - pv = &vector_elt(*pv, 0); + if (*penv == NIL) break; + penv = &vector_elt(*penv, 0); } if (__unlikely((v = sym->binding) == UNBOUND)) raise(list2(UnboundError, e)); return v; } - if (__unlikely(SP >= (N_STACK-MAX_ARGS))) - lerror(MemoryError, "eval: stack overflow"); + if (__unlikely(SP >= (N_STACK-MAX_ARGS-4))) + return new_stackseg(e, penv, tail); saveSP = SP; v = car_(e); PUSH(cdr_(e)); @@ -761,27 +806,32 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) goto apply_special; else if (f == TAG_CONST) f = ((symbol_t*)ptr(v))->binding; - else + else { noeval = 2; + PUSH(f); + v = Stack[saveSP]; + goto move_args; + } } else f = eval(v); + PUSH(f); v = Stack[saveSP]; + // evaluate argument list, placing arguments on stack + while (iscons(v)) { + if (SP-saveSP-2 == MAX_ARGS) { + v = evlis(&Stack[saveSP], penv); + PUSH(v); + break; + } + v = car_(v); + v = eval(v); + PUSH(v); + v = Stack[saveSP] = cdr_(Stack[saveSP]); + } + do_apply: + nargs = SP - saveSP - 2; if (isbuiltinish(f)) { // handle builtin function - // evaluate argument list, placing arguments on stack - while (iscons(v)) { - if (SP-saveSP-1 == MAX_ARGS) { - v = evlis(&Stack[saveSP], penv); - PUSH(v); - break; - } - v = car_(v); - v = eval(v); - PUSH(v); - v = Stack[saveSP] = cdr_(Stack[saveSP]); - } - apply_builtin: - nargs = SP - saveSP - 1; apply_special: switch (uintval(f)) { // special forms @@ -794,27 +844,26 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) e = car(Stack[saveSP]); v = car(cdr_(Stack[saveSP])); v = eval(v); - pv = &Stack[penv]; while (1) { - f = *pv++; + f = *penv++; while (iscons(f)) { if (car_(f)==e) { - *pv = v; + *penv = v; SP = saveSP; return v; } - f = cdr_(f); pv++; + f = cdr_(f); penv++; } if (f != NIL) { if (f == e) { - *pv = v; + *penv = v; SP = saveSP; return v; } - pv++; + penv++; } - if (*pv == NIL) break; - pv = &vector_elt(*pv, 0); + if (*penv == NIL) break; + penv = &vector_elt(*penv, 0); } sym = tosymbol(e, "set!"); if (sym->syntax != TAG_CONST) @@ -822,23 +871,23 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_LAMBDA: // build a closure (lambda args body . env) - if (Stack[penv] != NIL) { + if (*penv != NIL) { // save temporary environment to the heap lenv = penv; - envsz = numval(Stack[penv-1]); + envsz = numval(penv[-1]); pv = alloc_words(envsz + 1); PUSH(tagptr(pv, TAG_VECTOR)); pv[0] = fixnum(envsz); pv++; while (envsz--) - *pv++ = Stack[penv++]; + *pv++ = *penv++; // environment representation changed; install // the new representation so everybody can see it - Stack[lenv] = NIL; - Stack[lenv+1] = Stack[SP-1]; + lenv[0] = NIL; + lenv[1] = Stack[SP-1]; } else { - PUSH(Stack[penv+1]); // env has already been captured; share + PUSH(penv[1]); // env has already been captured; share } c = (cons_t*)ptr(v=cons_reserve(3)); e = Stack[saveSP]; @@ -917,17 +966,17 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_WHILE: PUSH(cdr(Stack[saveSP])); - body = &Stack[SP-1]; - PUSH(*body); + lenv = &Stack[SP-1]; + PUSH(*lenv); Stack[saveSP] = car_(Stack[saveSP]); value_t *cond = &Stack[saveSP]; PUSH(FL_F); pv = &Stack[SP-1]; while (eval(*cond) != FL_F) { - *body = Stack[SP-2]; - while (iscons(*body)) { - *pv = eval(car_(*body)); - *body = cdr_(*body); + *lenv = Stack[SP-2]; + while (iscons(*lenv)) { + *pv = eval(car_(*lenv)); + *lenv = cdr_(*lenv); } } v = *pv; @@ -1016,7 +1065,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) } else i = 0; v = alloc_vector(nargs+i, 0); - memcpy(&vector_elt(v,0), &Stack[saveSP+1], nargs*sizeof(value_t)); + memcpy(&vector_elt(v,0), &Stack[saveSP+2], nargs*sizeof(value_t)); if (i > 0) { e = Stack[SP-1]; while (iscons(e)) { @@ -1136,7 +1185,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_ADD: s = 0; - i = saveSP+1; + i = saveSP+2; if (nargs > MAX_ARGS) goto add_ovf; for (; i < (int)SP; i++) { if (__likely(isfixnum(Stack[i]))) { @@ -1157,7 +1206,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_SUB: if (__unlikely(nargs < 1)) lerror(ArgError, "-: too few arguments"); - i = saveSP+1; + i = saveSP+2; if (nargs == 1) { if (__likely(isfixnum(Stack[i]))) v = fixnum(-numval(Stack[i])); @@ -1190,7 +1239,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_MUL: accum = 1; - i = saveSP+1; + i = saveSP+2; if (nargs > MAX_ARGS) goto mul_ovf; for (; i < (int)SP; i++) { if (__likely(isfixnum(Stack[i]))) { @@ -1210,7 +1259,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_DIV: if (__unlikely(nargs < 1)) lerror(ArgError, "/: too few arguments"); - i = saveSP+1; + i = saveSP+2; if (nargs == 1) { v = fl_div2(fixnum(1), Stack[i]); } @@ -1276,25 +1325,25 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) v = Stack[SP-1]; if (selfevaluating(v)) { SP=saveSP; return v; } if (tail) { - Stack[penv-1] = fixnum(2); - Stack[penv] = NIL; - Stack[penv+1] = NIL; - SP = penv + 2; + assert((ulong_t)(penv-Stack) 0) + lerror(ArgError, "apply: too many arguments"); } else { - while (iscons(v)) { - // bind args - if (!iscons(*argsyms)) { - if (__unlikely(*argsyms == NIL)) - lerror(ArgError, "apply: too many arguments"); - break; + if (i > 0) { + list(&v, i, &NIL); + if (nargs > MAX_ARGS) { + c = (cons_t*)curheap; + (c-2)->cdr = (c-1)->car; } - v = car_(v); - v = eval(v); - PUSH(v); - *argsyms = cdr_(*argsyms); - v = Stack[saveSP] = cdr_(Stack[saveSP]); + Stack[SP-i] = v; + SP -= (i-1); } - if (*argsyms != NIL && issymbol(*argsyms)) { - PUSH(Stack[saveSP]); - // this version uses collective allocation. about 7-10% - // faster for lists with > 2 elements, but uses more - // stack space - i = SP; - while (iscons(Stack[saveSP])) { - v = car_(Stack[saveSP]); - v = eval(v); - PUSH(v); - Stack[saveSP] = cdr_(Stack[saveSP]); - } - if (SP > (uint32_t)i) - list(&Stack[i-1], SP-i, &Stack[saveSP]); + else { + PUSH(NIL); } } - if (__unlikely(iscons(*argsyms))) { - lerror(ArgError, "apply: too few arguments"); - } f = cdr_(Stack[saveSP+1]); if (!iscons(f)) goto notpair; e = car_(f); if (selfevaluating(e)) { SP=saveSP; return(e); } PUSH(cdr_(f)); // add closed environment - *argsyms = car_(Stack[saveSP+1]); // put lambda list + Stack[saveSP+1] = car_(Stack[saveSP+1]); // put lambda list + envsz = SP - saveSP - 1; if (noeval == 2) { // macro: evaluate body in lambda environment - Stack[saveSP+1] = fixnum(SP-saveSP-2); - e = eval_sexpr(e, saveSP+2, 1); + Stack[saveSP] = fixnum(envsz); + e = eval_sexpr(e, &Stack[saveSP+1], 1); SP = saveSP; if (selfevaluating(e)) return(e); noeval = 0; @@ -1433,19 +1450,17 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) goto eval_top; } else { - envsz = SP - saveSP - 2; if (tail) { - noeval = 0; // ok to overwrite environment + penv[-1] = fixnum(envsz); for(i=0; i < (int)envsz; i++) - Stack[penv+i] = Stack[saveSP+2+i]; - SP = penv+envsz; - Stack[penv-1] = fixnum(envsz); + penv[i] = Stack[saveSP+1+i]; + SP = (penv-Stack)+envsz; goto eval_top; } else { - Stack[saveSP+1] = fixnum(envsz); - v = eval_sexpr(e, saveSP+2, 1); + Stack[saveSP] = fixnum(envsz); + v = eval_sexpr(e, &Stack[saveSP+1], 1); SP = saveSP; return v; } @@ -1575,10 +1590,9 @@ value_t toplevel_eval(value_t expr) { value_t v; uint32_t saveSP = SP; - PUSH(fixnum(2)); PUSH(NIL); PUSH(NIL); - v = topeval(expr, SP-2); + v = topeval(expr, &Stack[SP-2]); SP = saveSP; return v; } diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 14479e3..5a70ea5 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -93,7 +93,7 @@ typedef struct _symbol_t { (((unsigned char*)ptr(v)) < fromspace+heapsize)) #define isgensym(x) (issymbol(x) && ismanaged(x)) -extern value_t Stack[]; +extern value_t *Stack; extern uint32_t SP; #define PUSH(v) (Stack[SP++] = (v)) #define POP() (Stack[--SP]) diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 8fa42a8..0ebf434 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -135,6 +135,11 @@ (nthcdr (cdr lst) (- n 1)))) (define list-tail nthcdr) +(define (list-head lst n) + (if (<= n 0) () + (cons (car lst) + (list-head (cdr lst) (- n 1))))) + (define (list-ref lst n) (car (nthcdr lst n))) @@ -482,7 +487,7 @@ (define (print . args) (apply io.print (cons *output-stream* args))) (define (princ . args) (apply io.princ (cons *output-stream* args))) -(define (newline) (princ *linefeed*)) +(define (newline) (princ *linefeed*) #t) (define (display x) (princ x) #t) (define (println . args) (prog1 (apply print args) (newline))) diff --git a/femtolisp/todo b/femtolisp/todo index f9d5320..527cd71 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -151,8 +151,8 @@ bugs: - (setf (car x) y) doesn't return y * reader needs to check errno in isnumtok * prettyprint size measuring is not utf-8 correct -- stack is too limited. possibly allocate user frames with alloca so the - only limit is the process stack size. +* stack is too limited. + . add extra heap-allocated stack segments as needed. * argument list length is too limited. need to fix it for: +,-,*,/,&,|,$,list,vector,apply,string,array . for builtins, make Nth argument list of rest args diff --git a/femtolisp/torture.scm b/femtolisp/torture.scm new file mode 100644 index 0000000..2f25e8c --- /dev/null +++ b/femtolisp/torture.scm @@ -0,0 +1,19 @@ +(define (big n) + (if (<= n 0) + 0 + `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1))))) + +(define nst `(display ,(big 100000))) + +(display (eval nst)) +(newline) + +(define (f x) + (begin (display x) + (newline) + (f (+ x 1)) + 0)) + +(define longg (cons '+ (map (lambda (x) 1) (iota 1000000)))) +(display (eval longg)) +(newline)