From 672558d30fdfffa9f3ede3c7b671d28285407437 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Wed, 15 Apr 2009 00:12:01 +0000 Subject: [PATCH] bytecode vm is now working, off by default various bug fixes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit language changes: • constant symbols no longer shadow everything • eval* removed • vararg lists always allocated on entry, dotted argument lists not preserved new applyn() entry point --- femtolisp/builtins.c | 5 +- femtolisp/compiler.lsp | 46 +++--- femtolisp/cps.lsp | 8 +- femtolisp/flisp.c | 344 ++++++++++++++++++++++++++--------------- femtolisp/flisp.h | 5 +- femtolisp/opcodes.h | 26 ++++ femtolisp/system.lsp | 14 +- femtolisp/table.c | 11 +- femtolisp/todo | 17 ++ 9 files changed, 313 insertions(+), 163 deletions(-) create mode 100644 femtolisp/opcodes.h diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 3731215..ac1c7fc 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -129,7 +129,7 @@ static value_t fl_intern(value_t *args, u_int32_t nargs) return symbol(cvalue_data(args[0])); } -extern value_t LAMBDA; +extern value_t LAMBDA, COMPILEDLAMBDA; static value_t fl_setsyntax(value_t *args, u_int32_t nargs) { @@ -142,7 +142,8 @@ static value_t fl_setsyntax(value_t *args, u_int32_t nargs) sym->syntax = 0; } else { - if (!iscons(args[1]) || car_(args[1])!=LAMBDA) + if (!iscons(args[1]) || (car_(args[1])!=LAMBDA && + car_(args[1])!=COMPILEDLAMBDA)) type_error("set-syntax!", "function", args[1]); sym->syntax = args[1]; } diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index aaac367..6f3dae9 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -8,13 +8,14 @@ (define Instructions (make-enum-table - [:nop :dup :pop :call :jmp :brf :brt :jmp.l :brf.l :brt.l :ret + [:nop :dup :pop :call :tcall :jmp :brf :brt :jmp.l :brf.l :brt.l :ret + :tapply :eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol? :number? :bound? :pair? :builtin? :vector? :fixnum? :cons :list :car :cdr :set-car! :set-cdr! - :eval :eval* :apply + :eval :apply :+ :- :* :/ :< :compare @@ -24,7 +25,7 @@ :loadg :loada :loadc :loadg.l :setg :seta :setc :setg.l - :closure :trycatch :tcall :tapply :argc :vargc])) + :closure :trycatch :argc :vargc])) (define arg-counts (table :eq? 2 :eqv? 2 @@ -37,10 +38,9 @@ :cons 2 :car 1 :cdr 1 :set-car! 2 :set-cdr! 2 :eval 1 - :eval* 1 :apply 2 - :< 2 :for 3 - :compare 2 :aref 2 - :aset! 3)) + :apply 2 :< 2 + :for 3 :compare 2 + :aref 2 :aset! 3)) (define 1/Instructions (table.invert Instructions)) @@ -181,11 +181,11 @@ `(closed ,lev ,i)) (lookup-sym s (cdr env) - (if (null? curr) lev (+ lev 1)) + (if (or arg? (null? curr)) lev (+ lev 1)) #f))))) (define (compile-sym g env s Is) - (let ((loc (lookup-sym s env -1 #t))) + (let ((loc (lookup-sym s env 0 #t))) (case (car loc) (arg (emit g (aref Is 0) (cadr loc))) (closed (emit g (aref Is 1) (cadr loc) (caddr loc))) @@ -199,13 +199,13 @@ (cond-clauses->if (cdr form))) (define (cond-clauses->if lst) (if (atom? lst) - lst - (let ((clause (car lst))) - (if (eq? (car clause) 'else) - (cons 'begin (cdr clause)) - `(if ,(car clause) - ,(cons 'begin (cdr clause)) - ,(cond-clauses->if (cdr lst))))))) + #f + (let ((clause (car lst))) + (if (eq? (car clause) 'else) + (cons 'begin (cdr clause)) + `(if ,(car clause) + ,(cons 'begin (cdr clause)) + ,(cond-clauses->if (cdr lst))))))) (define (compile-if g env tail? x) (let ((elsel (make-label g)) @@ -241,11 +241,12 @@ (define (compile-while g env cond body) (let ((top (make-label g)) (end (make-label g))) + (compile-in g env #f #f) (mark-label g top) (compile-in g env #f cond) (emit g :brf end) - (compile-in g env #f body) (emit g :pop) + (compile-in g env #f body) (emit g :jmp top) (mark-label g end))) @@ -365,12 +366,12 @@ (cond (compile-in g env tail? (cond->if x))) (if (compile-if g env tail? x)) (begin (compile-begin g env tail? (cdr x))) - (prog1 (compile-prog1 g env tail? x)) + (prog1 (compile-prog1 g env x)) (lambda (begin (emit g :loadv (compile-f env x)) (emit g :closure))) (and (compile-and g env tail? (cdr x))) (or (compile-or g env tail? (cdr x))) - (while (compile-while g env (cadr x) (caddr x))) + (while (compile-while g env (cadr x) (cons 'begin (cddr x)))) (set! (compile-in g env #f (caddr x)) (compile-sym g env (cadr x) [:seta :setc :setg])) (trycatch (compile-in g env #f `(lambda () ,(cadr x))) @@ -383,13 +384,14 @@ (args (cadr f))) (if (null? (lastcdr args)) (emit g :argc (length args)) - (emit g :vargc (length args))) + (emit g :vargc (if (atom? args) 0 (length args)))) (compile-in g (cons (to-proper args) env) #t (caddr f)) (emit g :ret) `(compiled-lambda ,args ,(bytecode g)))) -(define (compile x) - (bytecode (compile-in (make-code-emitter) () #t x))) +(define (compile f) (compile-f () f)) + +(define (compile-thunk expr) (compile `(lambda () ,expr))) (define (ref-uint32-LE a i) (+ (ash (aref a (+ i 0)) 0) diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index a94ea20..72ec341 100644 --- a/femtolisp/cps.lsp +++ b/femtolisp/cps.lsp @@ -8,7 +8,7 @@ (cond-clauses->if (cdr form))) (define (cond-clauses->if lst) (if (atom? lst) - lst + #f (let ((clause (car lst))) `(if ,(car clause) ,(cond-body (cdr clause)) @@ -22,13 +22,13 @@ ,(begin->cps (cdr forms) k))))))) (define-macro (lambda/cc args body) - `(set-car! (lambda ,args ,body) 'lambda/cc)) + `(cons 'lambda/cc (lambda ,args ,body))) ; a utility used at run time to dispatch a call with or without ; the continuation argument, depending on the function (define (funcall/cc f k . args) (if (and (pair? f) (eq (car f) 'lambda/cc)) - (apply f (cons k args)) + (apply (cdr f) (cons k args)) (k (apply f args)))) (define *funcall/cc-names* (list->vector @@ -38,7 +38,7 @@ (let ((name (aref *funcall/cc-names* (length args)))) `(define (,name f k ,@args) (if (and (pair? f) (eq (car f) 'lambda/cc)) - (f k ,@args) + ((cdr f) k ,@args) (k (f ,@args)))))) (def-funcall/cc-n ()) (def-funcall/cc-n (a0)) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 2a2b12a..0170ee5 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -55,7 +55,7 @@ static char *builtin_names[] = { // special forms "quote", "cond", "if", "and", "or", "while", "lambda", - "trycatch", "%apply", "set!", "prog1", "begin", + "trycatch", "%apply", "%applyn", "set!", "prog1", "begin", // predicates "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?", @@ -65,7 +65,7 @@ static char *builtin_names[] = "cons", "list", "car", "cdr", "set-car!", "set-cdr!", // execution - "eval", "eval*", "apply", + "eval", "apply", // arithmetic "+", "-", "*", "/", "<", "compare", @@ -96,7 +96,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, value_t *penv, int tail); +static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz); static value_t apply_cl(uint32_t nargs); static value_t *alloc_words(int n); static value_t relocate(value_t v); @@ -467,7 +467,7 @@ static void trace_globals(symbol_t *root) } } -static value_t special_apply_form; +static value_t special_apply_form, special_applyn_form; static value_t apply1_args; static value_t memory_exception_value; @@ -502,6 +502,7 @@ void gc(int mustgrow) } lasterror = relocate(lasterror); special_apply_form = relocate(special_apply_form); + special_applyn_form = relocate(special_applyn_form); apply1_args = relocate(apply1_args); memory_exception_value = relocate(memory_exception_value); @@ -551,8 +552,29 @@ value_t apply(value_t f, value_t l) value_t apply1(value_t f, value_t a0) { - car_(apply1_args) = a0; - return apply(f, apply1_args); + PUSH(f); + PUSH(a0); + PUSH(fixnum(1)); + value_t v = toplevel_eval(special_applyn_form); + POPN(3); + return v; +} + +value_t applyn(uint32_t n, value_t f, ...) +{ + va_list ap; + va_start(ap, f); + size_t i; + + PUSH(f); + for(i=0; i < n; i++) { + value_t a = va_arg(ap, value_t); + PUSH(a); + } + PUSH(fixnum(n)); + value_t v = toplevel_eval(special_applyn_form); + POPN(n+2); + return v; } value_t listn(size_t n, ...) @@ -634,40 +656,39 @@ int isnumber(value_t v) // eval ----------------------------------------------------------------------- /* - take the final cdr as an argument so the list builtin can give - the same result as (lambda x x). - - however, there is still one interesting difference. + there is one interesting difference between this and (lambda x x). (eq a (apply list a)) is always false for nonempty a, while (eq a (apply (lambda x x) a)) is always true. the justification for this is that a vararg lambda often needs to recur by applying itself to the tail of its argument list, so copying the list would be unacceptable. */ -static void list(value_t *pv, uint32_t nargs, value_t *plastcdr) +static value_t list(value_t *args, uint32_t nargs) { cons_t *c; uint32_t i; - *pv = cons_reserve(nargs); - c = (cons_t*)ptr(*pv); - for(i=SP-nargs; i < SP; i++) { - c->car = Stack[i]; + value_t v; + v = cons_reserve(nargs); + c = (cons_t*)ptr(v); + for(i=0; i < nargs; i++) { + c->car = args[i]; c->cdr = tagptr(c+1, TAG_CONS); c++; } if (nargs > MAX_ARGS) (c-2)->cdr = (c-1)->car; else - (c-1)->cdr = *plastcdr; + (c-1)->cdr = NIL; + return v; } -#define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0)) -#define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1)) +#define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0,envsz)) +#define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1,2)) #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 */ -static value_t evlis(value_t *pv, value_t *penv) +static value_t evlis(value_t *pv, value_t *penv, uint32_t envsz) { PUSH(NIL); PUSH(NIL); @@ -680,7 +701,7 @@ static value_t evlis(value_t *pv, value_t *penv) v = mk_cons(); car_(v) = Stack[SP-1]; cdr_(v) = NIL; - (void)POP(); + POPN(1); if (*rest == NIL) Stack[SP-2] = v; else @@ -688,7 +709,7 @@ static value_t evlis(value_t *pv, value_t *penv) *rest = v; v = *pv = cdr_(*pv); } - (void)POP(); + POPN(1); return POP(); } @@ -698,7 +719,7 @@ static value_t evlis(value_t *pv, value_t *penv) 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) +static value_t new_stackseg(value_t e, value_t *penv, int tail, uint32_t envsz) { stackseg_t s; @@ -713,7 +734,7 @@ static value_t new_stackseg(value_t e, value_t *penv, int tail) value_t v = NIL; int err = 0; FL_TRY { - v = eval_sexpr(e, penv, tail); + v = eval_sexpr(e, penv, tail, envsz); } FL_CATCH { err = 1; @@ -727,7 +748,7 @@ static value_t new_stackseg(value_t e, value_t *penv, int tail) return v; } -static value_t do_trycatch(value_t expr, value_t *penv) +static value_t do_trycatch(value_t expr, value_t *penv, uint32_t envsz) { value_t v; @@ -748,6 +769,23 @@ static value_t do_trycatch(value_t expr, value_t *penv) return v; } +static value_t do_trycatch2() +{ + value_t v; + value_t thunk = Stack[SP-2]; + Stack[SP-2] = Stack[SP-1]; + Stack[SP-1] = thunk; + + FL_TRY { + v = apply_cl(0); + } + FL_CATCH { + Stack[SP-1] = lasterror; + v = apply_cl(1); + } + return v; +} + /* stack setup on entry: n n+1 ... +-----+-----+-----+-----+-----+-----+-----+-----+ @@ -764,12 +802,12 @@ static value_t do_trycatch(value_t expr, value_t *penv) penv[-1] tells you the environment size, from LL through CLO, as a fixnum. */ -static value_t eval_sexpr(value_t e, value_t *penv, int tail) +static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz) { value_t f, v, *pv, *lenv; cons_t *c; symbol_t *sym; - uint32_t saveSP, bp, envsz, nargs; + uint32_t saveSP, bp, nargs; int i, noeval=0; fixnum_t s, lo, hi; int64_t accum; @@ -783,7 +821,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) eval_top: if (issymbol(e)) { sym = (symbol_t*)ptr(e); - if (sym->syntax == TAG_CONST) { SP=saveSP; return sym->binding; } while (1) { v = *penv++; while (iscons(v)) { @@ -803,7 +840,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) return v; } if (__unlikely(SP >= (N_STACK-MAX_ARGS-4))) { - v = new_stackseg(e, penv, tail); + v = new_stackseg(e, penv, tail, envsz); SP = saveSP; return v; } @@ -811,15 +848,13 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) v = car_(e); PUSH(cdr_(e)); if (selfevaluating(v)) f=v; - else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax)) { + else if (issymbol(v) && (f=((symbol_t*)ptr(v))->syntax) && f!=TAG_CONST) { // handle special syntax forms if (isspecial(f)) goto apply_special; - else if (f == TAG_CONST) - f = ((symbol_t*)ptr(v))->binding; else { - noeval = 2; PUSH(f); + noeval = 2; v = Stack[bp]; goto move_args; } @@ -830,7 +865,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) // evaluate argument list, placing arguments on stack while (iscons(v)) { if (SP-bp-2 == MAX_ARGS) { - v = evlis(&Stack[bp], penv); + v = evlis(&Stack[bp], penv, envsz); PUSH(v); break; } @@ -885,7 +920,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) if (*penv != NIL) { // save temporary environment to the heap lenv = penv; - envsz = numval(penv[-1]); pv = alloc_words(envsz + 1); PUSH(tagptr(pv, TAG_VECTOR)); pv[0] = fixnum(envsz); @@ -1019,7 +1053,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[bp]), penv); + v = do_trycatch(car(Stack[bp]), penv, envsz); break; // ordinary functions @@ -1043,11 +1077,10 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) v = tagptr(c, TAG_CONS); break; case F_LIST: - if (nargs) { - Stack[bp] = v; - list(&v, nargs, &Stack[bp]); - } - // else v is already set to the final cdr, which is the result + if (nargs) + v = list(&Stack[SP-nargs], nargs); + else + v = NIL; break; case F_CAR: argcount("car", nargs, 1); @@ -1296,59 +1329,59 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) argcount("eval", nargs, 1); e = Stack[SP-1]; if (selfevaluating(e)) { SP=saveSP; return e; } + envsz = 2; if (tail) { assert((ulong_t)(penv-Stack) bp+1); if (__likely(iscons(f))) { if (car_(f) == COMPILEDLAMBDA) { - v = apply_cl(nargs); - SP = saveSP; - return v; + e = apply_cl(nargs); + if (noeval == 2) { + if (selfevaluating(e)) { SP=saveSP; return(e); } + noeval = 0; + goto eval_top; + } + else { + SP = saveSP; + return e; + } } // apply lambda expression f = Stack[bp+1] = cdr_(f); @@ -1397,7 +1438,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) else { v = NIL; if (i > 0) { - list(&v, i, &NIL); + v = list(&Stack[SP-i], i); if (nargs > MAX_ARGS) { c = (cons_t*)curheap; (c-2)->cdr = (c-1)->car; @@ -1412,28 +1453,25 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) if (selfevaluating(e)) { SP=saveSP; return(e); } PUSH(cdr_(f)); // add closed environment Stack[bp+1] = car_(Stack[bp+1]); // put lambda list - envsz = SP - bp - 1; if (noeval == 2) { // macro: evaluate body in lambda environment - Stack[bp] = fixnum(envsz); - e = eval_sexpr(e, &Stack[bp+1], 1); + e = eval_sexpr(e, &Stack[bp+1], 1, SP - bp - 1); if (selfevaluating(e)) { SP=saveSP; return(e); } noeval = 0; // macro: evaluate expansion in calling environment goto eval_top; } else { + envsz = SP - bp - 1; if (tail) { // ok to overwrite environment - penv[-1] = fixnum(envsz); for(i=0; i < (int)envsz; i++) penv[i] = Stack[bp+1+i]; SP = (penv-Stack)+envsz; goto eval_top; } else { - Stack[bp] = fixnum(envsz); penv = &Stack[bp+1]; tail = 1; goto eval_top; @@ -1460,6 +1498,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) - check arg counts - allocate vararg array - push closed env, set up new environment + - restore SP ** need 'copyenv' instruction that moves env to heap, installs heap version as the current env, and pushes the result vector. @@ -1469,8 +1508,8 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail) */ static value_t apply_cl(uint32_t nargs) { - uint32_t i, n, ip, bp, envsz; - fixnum_t s; + uint32_t i, n, ip, bp, envsz, saveSP=SP; + fixnum_t s, lo, hi; int64_t accum; uint8_t op, *code; value_t func, v, bcode, x, e, ftl; @@ -1480,50 +1519,63 @@ static value_t apply_cl(uint32_t nargs) apply_cl_top: func = Stack[SP-nargs-1]; + assert(iscons(func)); + assert(iscons(cdr_(func))); + assert(iscons(cdr_(cdr_(func)))); ftl = cdr_(cdr_(func)); bcode = car_(ftl); code = cv_data((cvalue_t*)ptr(car_(bcode))); - i = code[1]; - if (nargs < i) + assert(!ismanaged((uptrint_t)code)); + if (nargs < code[1]) lerror(ArgError, "apply: too few arguments"); - if (code[0] == OP_VARGC) { - s = (fixnum_t)nargs - (fixnum_t)i; - v = NIL; - if (s > 0) { - list(&v, s, &NIL); - if (nargs > MAX_ARGS) { - c = (cons_t*)curheap; - (c-2)->cdr = (c-1)->car; - } - // reload movable pointers - func = Stack[SP-nargs-1]; - ftl = cdr_(cdr_(func)); - bcode = car_(ftl); - code = cv_data((cvalue_t*)ptr(car_(bcode))); - } - Stack[SP-s] = v; - SP -= (s-1); - nargs = i+1; - } - else if (nargs > i) { - lerror(ArgError, "apply: too many arguments"); - } bp = SP-nargs; x = cdr_(ftl); // cloenv Stack[bp-1] = car_(cdr_(func)); // lambda list penv = &Stack[bp-1]; PUSH(x); + // must keep a reference to the bcode object while executing it + PUSH(bcode); PUSH(cdr_(bcode)); pvals = &Stack[SP-1]; - ip = 2; + ip = 0; while (1) { op = code[ip++]; + dispatch: switch (op) { + case OP_ARGC: + if (nargs > code[ip++]) { + lerror(ArgError, "apply: too many arguments"); + } + break; + case OP_VARGC: + i = code[ip++]; + s = (fixnum_t)nargs - (fixnum_t)i; + v = NIL; + if (s > 0) { + v = list(&Stack[bp+i], s); + if (nargs > MAX_ARGS) { + c = (cons_t*)curheap; + (c-2)->cdr = (c-1)->car; + } + Stack[bp+i] = v; + Stack[bp+i+1] = Stack[bp+nargs]; + Stack[bp+i+2] = Stack[bp+nargs+1]; + Stack[bp+i+3] = Stack[bp+nargs+2]; + } + else { + PUSH(NIL); + Stack[SP-1] = Stack[SP-2]; + Stack[SP-2] = Stack[SP-3]; + Stack[SP-3] = Stack[SP-4]; + Stack[SP-4] = NIL; + } + nargs = i+1; + break; case OP_NOP: break; case OP_DUP: v = Stack[SP-1]; PUSH(v); break; - case OP_POP: (void)POP(); break; + case OP_POP: POPN(1); break; case OP_TCALL: case OP_CALL: i = code[ip++]; // nargs @@ -1534,9 +1586,13 @@ static value_t apply_cl(uint32_t nargs) if (uintval(func) > N_BUILTINS) { v = ((builtin_t)ptr(func))(&Stack[SP-i], i); } + else { + PUSH(fixnum(i)); + v = toplevel_eval(special_applyn_form); + } } - else { - if (iscons(func) && car_(func) == COMPILEDLAMBDA) { + else if (iscons(func)) { + if (car_(func) == COMPILEDLAMBDA) { if (op == OP_TCALL) { for(s=-1; s < (fixnum_t)i; s++) Stack[bp+s] = Stack[SP-i+s]; @@ -1548,6 +1604,13 @@ static value_t apply_cl(uint32_t nargs) v = apply_cl(i); } } + else { + PUSH(fixnum(i)); + v = toplevel_eval(special_applyn_form); + } + } + else { + type_error("apply", "function", func); } SP = s-i-1; PUSH(v); @@ -1574,11 +1637,11 @@ static value_t apply_cl(uint32_t nargs) if (v != FL_F) ip = *(uint32_t*)&code[ip]; else ip += 4; break; - case OP_RET: v = POP(); return v; + case OP_RET: v = POP(); SP = saveSP; return v; case OP_EQ: Stack[SP-2] = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F); - POP(); break; + POPN(1); break; case OP_EQV: if (Stack[SP-2] == Stack[SP-1]) { v = FL_T; @@ -1590,7 +1653,7 @@ static value_t apply_cl(uint32_t nargs) v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? FL_T : FL_F; } - Stack[SP-2] = v; POP(); + Stack[SP-2] = v; POPN(1); break; case OP_EQUAL: if (Stack[SP-2] == Stack[SP-1]) { @@ -1603,7 +1666,7 @@ static value_t apply_cl(uint32_t nargs) v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? FL_T : FL_F; } - Stack[SP-2] = v; POP(); + Stack[SP-2] = v; POPN(1); break; case OP_PAIRP: Stack[SP-1] = (iscons(Stack[SP-1]) ? FL_T : FL_F); break; @@ -1643,7 +1706,7 @@ static value_t apply_cl(uint32_t nargs) c->car = Stack[SP-2]; c->cdr = Stack[SP-1]; Stack[SP-2] = tagptr(c, TAG_CONS); - POP(); break; + POPN(1); break; case OP_CAR: c = tocons(Stack[SP-1], "car"); Stack[SP-1] = c->car; @@ -1654,13 +1717,16 @@ static value_t apply_cl(uint32_t nargs) break; case OP_SETCAR: car(Stack[SP-2]) = Stack[SP-1]; - POP(); break; + POPN(1); break; case OP_SETCDR: cdr(Stack[SP-2]) = Stack[SP-1]; - POP(); break; + POPN(1); break; case OP_LIST: i = code[ip++]; - list(&v, i, &NIL); + if (i > 0) + v = list(&Stack[SP-i], i); + else + v = NIL; POPN(i); PUSH(v); break; @@ -1668,7 +1734,6 @@ static value_t apply_cl(uint32_t nargs) v = toplevel_eval(POP()); PUSH(v); break; - case OP_EVALSTAR: case OP_TAPPLY: case OP_APPLY: @@ -1691,7 +1756,7 @@ static value_t apply_cl(uint32_t nargs) n = code[ip++]; i = SP-n; if (n > MAX_ARGS) goto add_ovf; - for (; i < (int)SP; i++) { + for (; i < SP; i++) { if (__likely(isfixnum(Stack[i]))) { s += numval(Stack[i]); if (__unlikely(!fits_fixnum(s))) { @@ -1725,7 +1790,7 @@ static value_t apply_cl(uint32_t nargs) if (__likely(bothfixnums(Stack[i], Stack[i+1]))) { s = numval(Stack[i]) - numval(Stack[i+1]); if (__likely(fits_fixnum(s))) { - POP(); + POPN(1); Stack[SP-1] = fixnum(s); break; } @@ -1752,7 +1817,7 @@ static value_t apply_cl(uint32_t nargs) n = code[ip++]; i = SP-n; if (n > MAX_ARGS) goto mul_ovf; - for (; i < (int)SP; i++) { + for (; i < SP; i++) { if (__likely(isfixnum(Stack[i]))) { accum *= numval(Stack[i]); } @@ -1798,12 +1863,12 @@ static value_t apply_cl(uint32_t nargs) v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? FL_T : FL_F; } - POP(); + POPN(1); Stack[SP-1] = v; break; case OP_COMPARE: Stack[SP-2] = compare(Stack[SP-2], Stack[SP-1]); - POP(); + POPN(1); break; case OP_VECTOR: @@ -1841,7 +1906,7 @@ static value_t apply_cl(uint32_t nargs) else { type_error("aref", "sequence", v); } - POP(); + POPN(1); Stack[SP-1] = v; break; case OP_ASET: @@ -1862,6 +1927,19 @@ static value_t apply_cl(uint32_t nargs) Stack[SP-1] = v; break; case OP_FOR: + lo = tofixnum(Stack[SP-3], "for"); + hi = tofixnum(Stack[SP-2], "for"); + //f = Stack[SP-1]; + v = FL_F; + SP += 2; + for(s=lo; s <= hi; s++) { + Stack[SP-2] = Stack[SP-3]; + Stack[SP-1] = fixnum(s); + v = apply_cl(1); + } + POPN(4); + Stack[SP-1] = v; + break; case OP_LOADT: PUSH(FL_T); break; case OP_LOADF: PUSH(FL_F); break; @@ -1869,19 +1947,22 @@ static value_t apply_cl(uint32_t nargs) case OP_LOAD0: PUSH(fixnum(0)); break; case OP_LOAD1: PUSH(fixnum(1)); break; case OP_LOADV: + assert(code[ip] < vector_size(*pvals)); v = vector_elt(*pvals, code[ip]); ip++; PUSH(v); break; case OP_LOADVL: - v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4; + v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; PUSH(v); break; case OP_LOADGL: - v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4; + v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; goto do_loadg; case OP_LOADG: + assert(code[ip] < vector_size(*pvals)); v = vector_elt(*pvals, code[ip]); ip++; do_loadg: + assert(issymbol(v)); sym = (symbol_t*)ptr(v); if (sym->binding == UNBOUND) raise(list2(UnboundError, v)); @@ -1889,11 +1970,13 @@ static value_t apply_cl(uint32_t nargs) break; case OP_SETGL: - v = vector_elt(*pvals, *(uint32_t*)code[ip]); ip+=4; + v = vector_elt(*pvals, *(uint32_t*)&code[ip]); ip+=4; goto do_setg; case OP_SETG: + assert(code[ip] < vector_size(*pvals)); v = vector_elt(*pvals, code[ip]); ip++; do_setg: + assert(issymbol(v)); sym = (symbol_t*)ptr(v); v = Stack[SP-1]; if (sym->syntax != TAG_CONST) @@ -1901,20 +1984,32 @@ static value_t apply_cl(uint32_t nargs) break; case OP_LOADA: + assert(nargs > 0); i = code[ip++]; - if (penv[0] == NIL) + if (penv[0] == NIL) { + assert(isvector(penv[1])); + assert(i+1 < vector_size(penv[1])); v = vector_elt(penv[1], i+1); - else + } + else { + assert(bp+i < SP); v = Stack[bp+i]; + } PUSH(v); break; case OP_SETA: + assert(nargs > 0); v = Stack[SP-1]; i = code[ip++]; - if (penv[0] == NIL) + if (penv[0] == NIL) { + assert(isvector(penv[1])); + assert(i+1 < vector_size(penv[1])); vector_elt(penv[1], i+1) = v; - else + } + else { + assert(bp+i < SP); Stack[bp+i] = v; + } break; case OP_LOADC: case OP_SETC: @@ -1932,6 +2027,8 @@ static value_t apply_cl(uint32_t nargs) } while (s--) v = vector_elt(v, vector_size(v)-1); + assert(isvector(v)); + assert(i < vector_size(v)); if (op == OP_SETC) vector_elt(v, i) = Stack[SP-1]; else @@ -1969,11 +2066,14 @@ static value_t apply_cl(uint32_t nargs) //if (!iscons(e=cdr_(e))) goto notpair; c->car = car_(e); //body c->cdr = Stack[SP-1]; //env - POP(); + POPN(1); Stack[SP-1] = v; break; case OP_TRYCATCH: + v = do_trycatch2(); + POPN(1); + Stack[SP-1] = v; break; } } @@ -2049,10 +2149,11 @@ static void lisp_init(void) set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH)); lasterror = NIL; special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL); + special_applyn_form = fl_cons(builtin(F_SPECIAL_APPLYN), NIL); apply1_args = fl_cons(NIL, NIL); i = 0; while (isspecial(builtin(i))) { - if (i != F_SPECIAL_APPLY) + if (i != F_SPECIAL_APPLY && i != F_SPECIAL_APPLYN) ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i); i++; } @@ -2096,7 +2197,6 @@ value_t toplevel_eval(value_t expr) { value_t v; uint32_t saveSP = SP; - PUSH(fixnum(2)); PUSH(NIL); PUSH(NIL); v = topeval(expr, &Stack[SP-2]); @@ -2111,7 +2211,7 @@ static value_t argv_list(int argc, char *argv[]) for(i=argc-1; i >= 0; i--) { PUSH(cvalue_static_cstring(argv[i])); Stack[SP-2] = fl_cons(Stack[SP-1], Stack[SP-2]); - (void)POP(); + POPN(1); } return POP(); } @@ -2149,7 +2249,7 @@ int main(int argc, char *argv[]) v = toplevel_eval(e); } ios_close(value2c(ios_t*,Stack[SP-1])); - (void)POP(); + POPN(1); PUSH(symbol_value(symbol("__start"))); PUSH(argv_list(argc, argv)); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 8c71290..0688587 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -117,14 +117,14 @@ extern uint32_t SP; enum { // special forms F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, - F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROG1, F_BEGIN, + F_TRYCATCH, F_SPECIAL_APPLY, F_SPECIAL_APPLYN, F_SETQ, F_PROG1, F_BEGIN, // functions F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP, F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR, - F_EVAL, F_EVALSTAR, F_APPLY, + F_EVAL, F_APPLY, F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_COMPARE, F_VECTOR, F_AREF, F_ASET, F_FOR, @@ -141,6 +141,7 @@ void print(ios_t *f, value_t v, int princ); value_t toplevel_eval(value_t expr); value_t apply(value_t f, value_t l); value_t apply1(value_t f, value_t a0); +value_t applyn(uint32_t n, value_t f, ...); value_t load_file(char *fname); /* object model manipulation */ diff --git a/femtolisp/opcodes.h b/femtolisp/opcodes.h new file mode 100644 index 0000000..9c8a01f --- /dev/null +++ b/femtolisp/opcodes.h @@ -0,0 +1,26 @@ +#ifndef __OPCODES_H_ +#define __OPCODES_H_ + +enum { + OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT, + OP_JMPL, OP_BRFL, OP_BRTL, OP_RET, OP_TAPPLY, + + OP_EQ, OP_EQV, OP_EQUAL, OP_ATOMP, OP_NOT, OP_NULLP, OP_BOOLEANP, + OP_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP, + OP_FIXNUMP, + + OP_CONS, OP_LIST, OP_CAR, OP_CDR, OP_SETCAR, OP_SETCDR, + OP_EVAL, OP_APPLY, + + OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_LT, OP_COMPARE, + + OP_VECTOR, OP_AREF, OP_ASET, OP_FOR, + + OP_LOADT, OP_LOADF, OP_LOADNIL, OP_LOAD0, OP_LOAD1, OP_LOADV, OP_LOADVL, + OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL, OP_SETG, OP_SETA, OP_SETC, + OP_SETGL, + + OP_CLOSURE, OP_TRYCATCH, OP_ARGC, OP_VARGC +}; + +#endif diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index a990a07..d3e183b 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -105,7 +105,8 @@ (define (char? x) (eq? (typeof x) 'wchar)) (define (function? x) (or (builtin? x) - (and (pair? x) (eq (car x) 'lambda)))) + (and (pair? x) (or (eq (car x) 'lambda) + (eq (car x) 'compiled-lambda))))) (define procedure? function?) (define (caar x) (car (car x))) @@ -642,6 +643,8 @@ (define (expand x) (macroexpand x)) +(define (load-process x) (eval (expand x))) + (define (load filename) (let ((F (file filename :read))) (trycatch @@ -649,15 +652,18 @@ (if (not (io.eof? F)) (next (read F) prev - (eval (expand E))) + (load-process E)) (begin (io.close F) ; evaluate last form in almost-tail position - (eval (expand E))))) + (load-process E)))) (lambda (e) (begin (io.close F) (raise `(load-error ,filename ,e))))))) +;(load (string *install-dir* *directory-separator* "compiler.lsp")) +;(define (load-process x) ((compile-thunk (expand x)))) + (define *banner* (string.tail " ; _ ; |_ _ _ |_ _ | . _ _ @@ -679,7 +685,7 @@ #t)))) (define (reploop) (when (trycatch (and (prompt) (newline)) - print-exception) + (lambda (e) (print-exception e))) (begin (newline) (reploop)))) (reploop) diff --git a/femtolisp/table.c b/femtolisp/table.c index 69e4f97..d2b10a1 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -168,18 +168,16 @@ value_t fl_table_del(value_t *args, uint32_t nargs) value_t fl_table_foldl(value_t *args, uint32_t nargs) { argcount("table.foldl", nargs, 3); - PUSH(listn(3, NIL, NIL, NIL)); htable_t *h = totable(args[2], "table.foldl"); size_t i, n = h->size; void **table = h->table; value_t c; for(i=0; i < n; i+=2) { if (table[i+1] != HT_NOTFOUND) { - c = Stack[SP-1]; - car_(c) = (value_t)table[i]; - car_(cdr_(c)) = (value_t)table[i+1]; - car_(cdr_(cdr_(c))) = args[1]; - args[1] = apply(args[0], c); + args[1] = applyn(3, args[0], + (value_t)table[i], + (value_t)table[i+1], + args[1]); // reload pointer h = (htable_t*)cv_data((cvalue_t*)ptr(args[2])); if (h->size != n) @@ -187,7 +185,6 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs) table = h->table; } } - (void)POP(); return args[1]; } diff --git a/femtolisp/todo b/femtolisp/todo index 527cd71..ec91681 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -1012,3 +1012,20 @@ typedef struct _fltype_t { struct _fltype_t *artype; // (array this) int marked; } fltype_t; + +----------------------------------------------------------------------------- + +new evaluator todo: + +- need builtin = to handle nans properly, fix equal? on nans +- builtin quasi-opaque function type + fields: signature, maxstack, bcode, vals, cloenv + function->vector +- make (for ...) a special form +- trycatch should require 2nd arg to be a lambda expression +- maxstack calculation, replace Stack with C stack, alloca + - stack traces and better debugging support +- lambda lifting +- let optimization +- have macroexpand use its own global syntax table +- be able to create/load an image file