From 5ab7a7c1e10e681ec792ffb7467f7250f374e88c Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Sun, 19 Apr 2009 22:22:17 +0000 Subject: [PATCH] adding new "translucent" function type for byte-compiled lambdas --- femtolisp/builtins.c | 6 +- femtolisp/compiler.lsp | 108 +++++++++++------------- femtolisp/cvalues.c | 13 +-- femtolisp/flisp.c | 185 +++++++++++++++++++++++++++++------------ femtolisp/flisp.h | 8 ++ femtolisp/read.c | 6 +- femtolisp/system.lsp | 4 +- femtolisp/todo | 2 +- 8 files changed, 201 insertions(+), 131 deletions(-) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index cd9ac66..9690534 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -147,7 +147,7 @@ static value_t fl_set_top_level_value(value_t *args, u_int32_t nargs) return args[1]; } -extern value_t LAMBDA, COMPILEDLAMBDA; +extern value_t LAMBDA; static value_t fl_setsyntax(value_t *args, u_int32_t nargs) { @@ -160,8 +160,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 && - car_(args[1])!=COMPILEDLAMBDA)) + if (!iscvalue(args[1]) && + (!iscons(args[1]) || car_(args[1])!=LAMBDA)) type_error("set-syntax!", "function", args[1]); sym->syntax = args[1]; } diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index 092fb47..e26a3fd 100644 --- a/femtolisp/compiler.lsp +++ b/femtolisp/compiler.lsp @@ -153,13 +153,6 @@ const-to-idx) cvec))) -(define (bytecode g) - (cons (cvalue.pin (encode-byte-code (aref g 0))) - (const-to-idx-vec g))) - -(define (bytecode:code b) (car b)) -(define (bytecode:vals b) (cdr b)) - (define (index-of item lst start) (cond ((null? lst) #f) ((eq item (car lst)) start) @@ -426,7 +419,8 @@ (else (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)))) + (function (encode-byte-code (aref g 0)) + (const-to-idx-vec g)))) (define (compile f) (compile-f () f)) @@ -445,56 +439,54 @@ (define (hex5 n) (pad-l (number->string n 16) 5 #\0)) -(define (disassemble- b lev) - (if (and (pair? b) - (eq? (car b) 'compiled-lambda)) - (disassemble- (caddr b) lev) - (let ((code (bytecode:code b)) - (vals (bytecode:vals b))) - (define (print-val v) - (if (and (pair? v) (eq? (car v) 'compiled-lambda)) - (begin (princ "\n") - (disassemble- v (+ lev 1))) - (print v))) - (let ((i 0) - (N (length code))) - (while (< i N) - (let ((inst (get 1/Instructions (aref code i)))) - (if (> i 0) (newline)) - (dotimes (xx lev) (princ "\t")) - (princ (hex5 i) ": " - (string.tail (string inst) 1) "\t") - (set! i (+ i 1)) - (case inst - ((:loadv.l :loadg.l :setg.l) - (print-val (aref vals (ref-uint32-LE code i))) - (set! i (+ i 4))) +(define (disassemble- f lev) + (let ((fvec (function->vector f))) + (let ((code (aref fvec 0)) + (vals (aref fvec 1))) + (define (print-val v) + (if (and (pair? v) (eq? (car v) 'compiled-lambda)) + (begin (princ "\n") + (disassemble- v (+ lev 1))) + (print v))) + (let ((i 0) + (N (length code))) + (while (< i N) + (let ((inst (get 1/Instructions (aref code i)))) + (if (> i 0) (newline)) + (dotimes (xx lev) (princ "\t")) + (princ (hex5 i) ": " + (string.tail (string inst) 1) "\t") + (set! i (+ i 1)) + (case inst + ((:loadv.l :loadg.l :setg.l) + (print-val (aref vals (ref-uint32-LE code i))) + (set! i (+ i 4))) + + ((:loadv :loadg :setg) + (print-val (aref vals (aref code i))) + (set! i (+ i 1))) + + ((:loada :seta :call :tcall :list :+ :- :* :/ :vector + :argc :vargc :loadi8 :let) + (princ (number->string (aref code i))) + (set! i (+ i 1))) + + ((:loadc :setc) + (princ (number->string (aref code i)) " ") + (set! i (+ i 1)) + (princ (number->string (aref code i))) + (set! i (+ i 1))) + + ((:jmp :brf :brt) + (princ "@" (hex5 (ref-uint16-LE code i))) + (set! i (+ i 2))) + + ((:jmp.l :brf.l :brt.l) + (princ "@" (hex5 (ref-uint32-LE code i))) + (set! i (+ i 4))) + + (else #f)))))))) - ((:loadv :loadg :setg) - (print-val (aref vals (aref code i))) - (set! i (+ i 1))) - - ((:loada :seta :call :tcall :list :+ :- :* :/ :vector - :argc :vargc :loadi8 :let) - (princ (number->string (aref code i))) - (set! i (+ i 1))) - - ((:loadc :setc) - (princ (number->string (aref code i)) " ") - (set! i (+ i 1)) - (princ (number->string (aref code i))) - (set! i (+ i 1))) - - ((:jmp :brf :brt) - (princ "@" (hex5 (ref-uint16-LE code i))) - (set! i (+ i 2))) - - ((:jmp.l :brf.l :brt.l) - (princ "@" (hex5 (ref-uint32-LE code i))) - (set! i (+ i 4))) - - (else #f)))))))) - -(define (disassemble b) (disassemble- b 0) (newline)) +(define (disassemble f) (disassemble- f 0) (newline)) #t diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index d3f8bb4..1e76339 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -78,6 +78,9 @@ static void sweep_finalizers() t->vtable->finalize(tagptr(tmp, TAG_CVALUE)); } if (!isinlined(tmp) && owned(tmp)) { +#ifndef NDEBUG + memset(cv_data(tmp), 0xbb, cv_len(tmp)); +#endif free(cv_data(tmp)); } ndel++; @@ -709,15 +712,6 @@ value_t fl_podp(value_t *args, u_int32_t nargs) FL_T : FL_F; } -value_t fl_cv_pin(value_t *args, u_int32_t nargs) -{ - argcount("cvalue.pin", nargs, 1); - if (!iscvalue(args[0])) - lerror(ArgError, "cvalue.pin: must be a byte array"); - cv_pin((cvalue_t*)ptr(args[0])); - return args[0]; -} - static void cvalue_init(fltype_t *type, value_t v, void *dest) { cvinitfunc_t f=type->init; @@ -922,7 +916,6 @@ static builtinspec_t cvalues_builtin_info[] = { { "sizeof", cvalue_sizeof }, { "builtin", fl_builtin }, { "copy", fl_copy }, - { "cvalue.pin", fl_cv_pin }, { "plain-old-data?", fl_podp }, { "logand", fl_logand }, diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 8dd1ebd..e178107 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -99,12 +99,13 @@ 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, COMPILEDLAMBDA; +value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION; value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t DivideError, BoundsError, Error, KeyError, EnumerationError; 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 fltype_t *functiontype; static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz); static value_t apply_cl(uint32_t nargs); @@ -470,7 +471,7 @@ static void trace_globals(symbol_t *root) while (root != NULL) { if (root->binding != UNBOUND) root->binding = relocate(root->binding); - if (iscons(root->syntax)) + if (iscons(root->syntax) || iscvalue(root->syntax)) root->syntax = relocate(root->syntax); trace_globals(root->left); root = root->right; @@ -1441,21 +1442,21 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz) } f = Stack[bp+1]; assert((signed)SP > (signed)bp+1); - if (__likely(iscons(f))) { - if (car_(f) == COMPILEDLAMBDA) { - i = SP; - e = apply_cl(nargs); - SP = i; - if (noeval == 2) { - if (selfevaluating(e)) { SP=saveSP; return(e); } - noeval = 0; - goto eval_top; - } - else { - SP = saveSP; - return e; - } + if (isfunction(f)) { + i = SP; + e = apply_cl(nargs); + SP = i; + if (noeval == 2) { + if (selfevaluating(e)) { SP=saveSP; return(e); } + noeval = 0; + goto eval_top; } + else { + SP = saveSP; + return e; + } + } + else if (__likely(iscons(f))) { // apply lambda expression f = Stack[bp+1] = cdr_(f); if (!iscons(f)) goto notpair; @@ -1550,7 +1551,8 @@ static value_t apply_cl(uint32_t nargs) fixnum_t s, lo, hi; int64_t accum; uint8_t *code; - value_t func, v, bcode, x, e; + value_t func, v, x, e; + function_t *fn; value_t *pvals, *lenv, *pv; symbol_t *sym; cons_t *c; @@ -1558,20 +1560,17 @@ static value_t apply_cl(uint32_t nargs) apply_cl_top: captured = 0; func = Stack[SP-nargs-1]; - assert(iscons(func)); - assert(iscons(cdr_(func))); - assert(iscons(cdr_(cdr_(func)))); - x = cdr_(cdr_(func)); - bcode = car_(x); - code = cv_data((cvalue_t*)ptr(car_(bcode))); + fn = value2c(function_t*,func); + code = cv_data((cvalue_t*)ptr(fn->bcode)); assert(!ismanaged((uptrint_t)code)); + assert(ismanaged(func)); + assert(ismanaged(fn->bcode)); if (nargs < code[1]) lerror(ArgError, "apply: too few arguments"); bp = SP-nargs; - x = cdr_(x); // cloenv - PUSH(x); - PUSH(cdr_(bcode)); + PUSH(fn->env); + PUSH(fn->vals); pvals = &Stack[SP-1]; ip = 0; @@ -1653,23 +1652,21 @@ static value_t apply_cl(uint32_t nargs) } } } - 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]; - SP = bp+i; - nargs = i; - goto apply_cl_top; - } - else { - v = apply_cl(i); - } + else if (isfunction(func)) { + if (op == OP_TCALL) { + for(s=-1; s < (fixnum_t)i; s++) + Stack[bp+s] = Stack[SP-i+s]; + SP = bp+i; + nargs = i; + goto apply_cl_top; } else { - v = _applyn(i); + v = apply_cl(i); } } + else if (iscons(func)) { + v = _applyn(i); + } else { type_error("apply", "function", func); } @@ -2140,19 +2137,20 @@ static value_t apply_cl(uint32_t nargs) PUSH(Stack[bp]); // env has already been captured; share } if (op == OP_CLOSURE) { - c = (cons_t*)ptr(v=cons_reserve(3)); - e = cdr_(Stack[SP-2]); // closure to copy - //if (!iscons(e)) goto notpair; - c->car = COMPILEDLAMBDA; - c->cdr = tagptr(c+1, TAG_CONS); c++; - c->car = car_(e); //argsyms - c->cdr = tagptr(c+1, TAG_CONS); c++; - e = cdr_(e); - //if (!iscons(e=cdr_(e))) goto notpair; - c->car = car_(e); //body - c->cdr = Stack[SP-1]; //env - POPN(1); - Stack[SP-1] = v; + pv = alloc_words(6); + x = Stack[SP-2]; // closure to copy + assert(isfunction(x)); + pv[0] = ((value_t*)ptr(x))[0]; + assert(pv[0] == functiontype); + pv[1] = (value_t)&pv[3]; + pv[2] = ((value_t*)ptr(x))[2]; + pv[3] = ((value_t*)ptr(x))[3]; + assert(isstring(pv[3])); + pv[4] = ((value_t*)ptr(x))[4]; + assert(isvector(pv[4])); + pv[5] = Stack[SP-1]; // env + POPN(1); + Stack[SP-1] = tagptr(pv, TAG_CVALUE); } break; @@ -2180,6 +2178,80 @@ void assign_global_builtins(builtinspec_t *b) } } +static void print_function(value_t v, ios_t *f, int princ) +{ + (void)princ; + function_t *fn = value2c(function_t*,v); + outs("#function(", f); + int newindent = HPOS; + fl_print_child(f, fn->bcode, 0); outindent(newindent, f); + fl_print_child(f, fn->vals, 0); outindent(newindent, f); + fl_print_child(f, fn->env, 0); + outc(')', f); +} + +static void print_traverse_function(value_t v) +{ + function_t *fn = value2c(function_t*,v); + print_traverse(fn->bcode); + print_traverse(fn->vals); + print_traverse(fn->env); +} + +static void relocate_function(value_t oldv, value_t newv) +{ + (void)oldv; + function_t *fn = value2c(function_t*,newv); + fn->bcode = relocate(fn->bcode); + fn->vals = relocate(fn->vals); + fn->env = relocate(fn->env); +} + +static value_t fl_function(value_t *args, uint32_t nargs) +{ + if (nargs != 3) + argcount("function", nargs, 2); + if (!isstring(args[0])) + type_error("function", "string", args[0]); + if (!isvector(args[1])) + type_error("function", "vector", args[1]); + cv_pin((cvalue_t*)ptr(args[0])); + value_t fv = cvalue(functiontype, sizeof(function_t)); + function_t *fn = value2c(function_t*,fv); + fn->bcode = args[0]; + fn->vals = args[1]; + if (nargs == 3) + fn->env = args[2]; + else + fn->env = NIL; + return fv; +} + +static value_t fl_function2vector(value_t *args, uint32_t nargs) +{ + argcount("function->vector", nargs, 1); + value_t v = args[0]; + if (!iscvalue(v) || cv_class((cvalue_t*)ptr(v)) != functiontype) + type_error("function->vector", "function", v); + value_t vec = alloc_vector(3, 0); + function_t *fn = value2c(function_t*,args[0]); + vector_elt(vec,0) = fn->bcode; + vector_elt(vec,1) = fn->vals; + vector_elt(vec,2) = fn->env; + return vec; +} + +static cvtable_t function_vtable = { print_function, relocate_function, + NULL, print_traverse_function }; + +static builtinspec_t core_builtin_info[] = { + { "function", fl_function }, + { "function->vector", fl_function2vector }, + { "gensym", gensym }, + { "hash", fl_hash }, + { NULL, NULL } +}; + static void lisp_init(void) { int i; @@ -2198,7 +2270,7 @@ static void lisp_init(void) FL_T = builtin(F_TRUE); FL_F = builtin(F_FALSE); LAMBDA = symbol("lambda"); - COMPILEDLAMBDA = symbol("compiled-lambda"); + FUNCTION = symbol("function"); QUOTE = symbol("quote"); TRYCATCH = symbol("trycatch"); BACKQUOTE = symbol("backquote"); @@ -2259,8 +2331,6 @@ static void lisp_init(void) #endif cvalues_init(); - set(symbol("gensym"), cbuiltin("gensym", gensym)); - set(symbol("hash"), cbuiltin("hash", fl_hash)); char buf[1024]; char *exename = get_exename(buf, sizeof(buf)); @@ -2273,6 +2343,11 @@ static void lisp_init(void) memory_exception_value = list2(MemoryError, cvalue_static_cstring("out of memory")); + functiontype = define_opaque_type(FUNCTION, sizeof(function_t), + &function_vtable, NULL); + + assign_global_builtins(core_builtin_info); + builtins_init(); } diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 2a7d052..14a8375 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -93,6 +93,8 @@ typedef struct _symbol_t { (((unsigned char*)ptr(v)) < fromspace+heapsize)) #define isgensym(x) (issymbol(x) && ismanaged(x)) +#define isfunction(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==functiontype)) + extern value_t *Stack; extern uint32_t SP; #define PUSH(v) (Stack[SP++] = (v)) @@ -223,6 +225,12 @@ typedef struct { char _space[1]; } cprim_t; +typedef struct { + value_t bcode; + value_t vals; + value_t env; +} function_t; + #define CPRIM_NWORDS 2 #define MAX_INL_SIZE 96 diff --git a/femtolisp/read.c b/femtolisp/read.c index 62953ad..aeb224d 100644 --- a/femtolisp/read.c +++ b/femtolisp/read.c @@ -551,8 +551,10 @@ static value_t do_read_sexpr(value_t label) } PUSH(NIL); read_list(&Stack[SP-1], UNBOUND); - v = POP(); - return apply(toplevel_eval(sym), v); + v = symbol_value(sym); + if (v == UNBOUND) + raise(list2(UnboundError, sym)); + return apply(v, POP()); case TOK_OPENB: return read_vector(label, TOK_CLOSEB); case TOK_SHARPOPEN: diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 6ee273e..bf3e5de 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -102,8 +102,8 @@ (define (char? x) (eq? (typeof x) 'wchar)) (define (function? x) (or (builtin? x) - (and (pair? x) (or (eq (car x) 'lambda) - (eq (car x) 'compiled-lambda))))) + (eq (typeof x) 'function) + (and (pair? x) (eq (car x) 'lambda)))) (define procedure? function?) (define (caar x) (car (car x))) diff --git a/femtolisp/todo b/femtolisp/todo index acfe243..08a05f8 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -1018,7 +1018,7 @@ typedef struct _fltype_t { new evaluator todo: * need builtin = to handle nans properly, fix equal? on nans -- builtin quasi-opaque function type +* builtin quasi-opaque function type fields: signature, maxstack, bcode, vals, cloenv function->vector * make (for ...) a special form