ref: 5ab7a7c1e10e681ec792ffb7467f7250f374e88c
parent: aa62ae9e9640131f1ce4e158f7834878df7fd8eb
author: JeffBezanson <[email protected]>
date: Sun Apr 19 18:22:17 EDT 2009
adding new "translucent" function type for byte-compiled lambdas
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -147,7 +147,7 @@
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 @@
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];
}
--- 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
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -78,6 +78,9 @@
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 @@
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 @@
{ "sizeof", cvalue_sizeof }, { "builtin", fl_builtin }, { "copy", fl_copy },- { "cvalue.pin", fl_cv_pin }, { "plain-old-data?", fl_podp }, { "logand", fl_logand },--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -99,12 +99,13 @@
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 @@
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 @@
}
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 @@
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 @@
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 @@
}
}
}
- 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 @@
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 @@
}
}
+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 @@
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 @@
#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));
@@ -2272,6 +2342,11 @@
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();
}
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -93,6 +93,8 @@
(((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))
@@ -222,6 +224,12 @@
fltype_t *type;
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
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -551,8 +551,10 @@
}
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:
--- 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)))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1018,7 +1018,7 @@
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