lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

adding new "translucent" function type for byte-compiled lambdas

This commit is contained in:
JeffBezanson 2009-04-19 22:22:17 +00:00
parent aa62ae9e96
commit 5ab7a7c1e1
8 changed files with 201 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
femtolisp/builtins.c
View File

@ -147,7 +147,7 @@ static value_t fl_set_top_level_value(value_t *args, u_int32_t nargs)
return args[1]; return args[1];
} }
extern value_t LAMBDA, COMPILEDLAMBDA; extern value_t LAMBDA;
static value_t fl_setsyntax(value_t *args, u_int32_t nargs) 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; sym->syntax = 0;
} }
else { else {
if (!iscons(args[1]) || (car_(args[1])!=LAMBDA && if (!iscvalue(args[1]) &&
car_(args[1])!=COMPILEDLAMBDA)) (!iscons(args[1]) || car_(args[1])!=LAMBDA))
type_error("set-syntax!", "function", args[1]); type_error("set-syntax!", "function", args[1]);
sym->syntax = args[1]; sym->syntax = args[1];
} }

96
femtolisp/compiler.lsp
View File

@ -153,13 +153,6 @@
const-to-idx) const-to-idx)
cvec))) 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) (define (index-of item lst start)
(cond ((null? lst) #f) (cond ((null? lst) #f)
((eq item (car lst)) start) ((eq item (car lst)) start)
@ -426,7 +419,8 @@
(else (emit g :vargc (if (atom? args) 0 (length args))))) (else (emit g :vargc (if (atom? args) 0 (length args)))))
(compile-in g (cons (to-proper args) env) #t (caddr f)) (compile-in g (cons (to-proper args) env) #t (caddr f))
(emit g :ret) (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)) (define (compile f) (compile-f () f))
@ -445,56 +439,54 @@
(define (hex5 n) (define (hex5 n)
(pad-l (number->string n 16) 5 #\0)) (pad-l (number->string n 16) 5 #\0))
(define (disassemble- b lev) (define (disassemble- f lev)
(if (and (pair? b) (let ((fvec (function->vector f)))
(eq? (car b) 'compiled-lambda)) (let ((code (aref fvec 0))
(disassemble- (caddr b) lev) (vals (aref fvec 1)))
(let ((code (bytecode:code b)) (define (print-val v)
(vals (bytecode:vals b))) (if (and (pair? v) (eq? (car v) 'compiled-lambda))
(define (print-val v) (begin (princ "\n")
(if (and (pair? v) (eq? (car v) 'compiled-lambda)) (disassemble- v (+ lev 1)))
(begin (princ "\n") (print v)))
(disassemble- v (+ lev 1))) (let ((i 0)
(print v))) (N (length code)))
(let ((i 0) (while (< i N)
(N (length code))) (let ((inst (get 1/Instructions (aref code i))))
(while (< i N) (if (> i 0) (newline))
(let ((inst (get 1/Instructions (aref code i)))) (dotimes (xx lev) (princ "\t"))
(if (> i 0) (newline)) (princ (hex5 i) ": "
(dotimes (xx lev) (princ "\t")) (string.tail (string inst) 1) "\t")
(princ (hex5 i) ": " (set! i (+ i 1))
(string.tail (string inst) 1) "\t") (case inst
(set! i (+ i 1)) ((:loadv.l :loadg.l :setg.l)
(case inst (print-val (aref vals (ref-uint32-LE code i)))
((:loadv.l :loadg.l :setg.l) (set! i (+ i 4)))
(print-val (aref vals (ref-uint32-LE code i)))
(set! i (+ i 4)))
((:loadv :loadg :setg) ((:loadv :loadg :setg)
(print-val (aref vals (aref code i))) (print-val (aref vals (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loada :seta :call :tcall :list :+ :- :* :/ :vector ((:loada :seta :call :tcall :list :+ :- :* :/ :vector
:argc :vargc :loadi8 :let) :argc :vargc :loadi8 :let)
(princ (number->string (aref code i))) (princ (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loadc :setc) ((:loadc :setc)
(princ (number->string (aref code i)) " ") (princ (number->string (aref code i)) " ")
(set! i (+ i 1)) (set! i (+ i 1))
(princ (number->string (aref code i))) (princ (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:jmp :brf :brt) ((:jmp :brf :brt)
(princ "@" (hex5 (ref-uint16-LE code i))) (princ "@" (hex5 (ref-uint16-LE code i)))
(set! i (+ i 2))) (set! i (+ i 2)))
((:jmp.l :brf.l :brt.l) ((:jmp.l :brf.l :brt.l)
(princ "@" (hex5 (ref-uint32-LE code i))) (princ "@" (hex5 (ref-uint32-LE code i)))
(set! i (+ i 4))) (set! i (+ i 4)))
(else #f)))))))) (else #f))))))))
(define (disassemble b) (disassemble- b 0) (newline)) (define (disassemble f) (disassemble- f 0) (newline))
#t #t

13
femtolisp/cvalues.c
View File

@ -78,6 +78,9 @@ static void sweep_finalizers()
t->vtable->finalize(tagptr(tmp, TAG_CVALUE)); t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
} }
if (!isinlined(tmp) && owned(tmp)) { if (!isinlined(tmp) && owned(tmp)) {
#ifndef NDEBUG
memset(cv_data(tmp), 0xbb, cv_len(tmp));
#endif
free(cv_data(tmp)); free(cv_data(tmp));
} }
ndel++; ndel++;
@ -709,15 +712,6 @@ value_t fl_podp(value_t *args, u_int32_t nargs)
FL_T : FL_F; 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) static void cvalue_init(fltype_t *type, value_t v, void *dest)
{ {
cvinitfunc_t f=type->init; cvinitfunc_t f=type->init;
@ -922,7 +916,6 @@ static builtinspec_t cvalues_builtin_info[] = {
{ "sizeof", cvalue_sizeof }, { "sizeof", cvalue_sizeof },
{ "builtin", fl_builtin }, { "builtin", fl_builtin },
{ "copy", fl_copy }, { "copy", fl_copy },
{ "cvalue.pin", fl_cv_pin },
{ "plain-old-data?", fl_podp }, { "plain-old-data?", fl_podp },
{ "logand", fl_logand }, { "logand", fl_logand },

185
femtolisp/flisp.c
View File

@ -99,12 +99,13 @@ stackseg_t stackseg0 = { StaticStack, 0, NULL };
stackseg_t *current_stack_seg = &stackseg0; stackseg_t *current_stack_seg = &stackseg0;
value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH; 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 IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error, KeyError, EnumerationError; value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym; value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym; 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 eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz);
static value_t apply_cl(uint32_t nargs); static value_t apply_cl(uint32_t nargs);
@ -470,7 +471,7 @@ static void trace_globals(symbol_t *root)
while (root != NULL) { while (root != NULL) {
if (root->binding != UNBOUND) if (root->binding != UNBOUND)
root->binding = relocate(root->binding); root->binding = relocate(root->binding);
if (iscons(root->syntax)) if (iscons(root->syntax) || iscvalue(root->syntax))
root->syntax = relocate(root->syntax); root->syntax = relocate(root->syntax);
trace_globals(root->left); trace_globals(root->left);
root = root->right; 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]; f = Stack[bp+1];
assert((signed)SP > (signed)bp+1); assert((signed)SP > (signed)bp+1);
if (__likely(iscons(f))) { if (isfunction(f)) {
if (car_(f) == COMPILEDLAMBDA) { i = SP;
i = SP; e = apply_cl(nargs);
e = apply_cl(nargs); SP = i;
SP = i; if (noeval == 2) {
if (noeval == 2) { if (selfevaluating(e)) { SP=saveSP; return(e); }
if (selfevaluating(e)) { SP=saveSP; return(e); } noeval = 0;
noeval = 0; goto eval_top;
goto eval_top;
}
else {
SP = saveSP;
return e;
}
} }
else {
SP = saveSP;
return e;
}
}
else if (__likely(iscons(f))) {
// apply lambda expression // apply lambda expression
f = Stack[bp+1] = cdr_(f); f = Stack[bp+1] = cdr_(f);
if (!iscons(f)) goto notpair; if (!iscons(f)) goto notpair;
@ -1550,7 +1551,8 @@ static value_t apply_cl(uint32_t nargs)
fixnum_t s, lo, hi; fixnum_t s, lo, hi;
int64_t accum; int64_t accum;
uint8_t *code; uint8_t *code;
value_t func, v, bcode, x, e; value_t func, v, x, e;
function_t *fn;
value_t *pvals, *lenv, *pv; value_t *pvals, *lenv, *pv;
symbol_t *sym; symbol_t *sym;
cons_t *c; cons_t *c;
@ -1558,20 +1560,17 @@ static value_t apply_cl(uint32_t nargs)
apply_cl_top: apply_cl_top:
captured = 0; captured = 0;
func = Stack[SP-nargs-1]; func = Stack[SP-nargs-1];
assert(iscons(func)); fn = value2c(function_t*,func);
assert(iscons(cdr_(func))); code = cv_data((cvalue_t*)ptr(fn->bcode));
assert(iscons(cdr_(cdr_(func))));
x = cdr_(cdr_(func));
bcode = car_(x);
code = cv_data((cvalue_t*)ptr(car_(bcode)));
assert(!ismanaged((uptrint_t)code)); assert(!ismanaged((uptrint_t)code));
assert(ismanaged(func));
assert(ismanaged(fn->bcode));
if (nargs < code[1]) if (nargs < code[1])
lerror(ArgError, "apply: too few arguments"); lerror(ArgError, "apply: too few arguments");
bp = SP-nargs; bp = SP-nargs;
x = cdr_(x); // cloenv PUSH(fn->env);
PUSH(x); PUSH(fn->vals);
PUSH(cdr_(bcode));
pvals = &Stack[SP-1]; pvals = &Stack[SP-1];
ip = 0; ip = 0;
@ -1653,23 +1652,21 @@ static value_t apply_cl(uint32_t nargs)
} }
} }
} }
else if (iscons(func)) { else if (isfunction(func)) {
if (car_(func) == COMPILEDLAMBDA) { if (op == OP_TCALL) {
if (op == OP_TCALL) { for(s=-1; s < (fixnum_t)i; s++)
for(s=-1; s < (fixnum_t)i; s++) Stack[bp+s] = Stack[SP-i+s];
Stack[bp+s] = Stack[SP-i+s]; SP = bp+i;
SP = bp+i; nargs = i;
nargs = i; goto apply_cl_top;
goto apply_cl_top;
}
else {
v = apply_cl(i);
}
} }
else { else {
v = _applyn(i); v = apply_cl(i);
} }
} }
else if (iscons(func)) {
v = _applyn(i);
}
else { else {
type_error("apply", "function", func); 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 PUSH(Stack[bp]); // env has already been captured; share
} }
if (op == OP_CLOSURE) { if (op == OP_CLOSURE) {
c = (cons_t*)ptr(v=cons_reserve(3)); pv = alloc_words(6);
e = cdr_(Stack[SP-2]); // closure to copy x = Stack[SP-2]; // closure to copy
//if (!iscons(e)) goto notpair; assert(isfunction(x));
c->car = COMPILEDLAMBDA; pv[0] = ((value_t*)ptr(x))[0];
c->cdr = tagptr(c+1, TAG_CONS); c++; assert(pv[0] == functiontype);
c->car = car_(e); //argsyms pv[1] = (value_t)&pv[3];
c->cdr = tagptr(c+1, TAG_CONS); c++; pv[2] = ((value_t*)ptr(x))[2];
e = cdr_(e); pv[3] = ((value_t*)ptr(x))[3];
//if (!iscons(e=cdr_(e))) goto notpair; assert(isstring(pv[3]));
c->car = car_(e); //body pv[4] = ((value_t*)ptr(x))[4];
c->cdr = Stack[SP-1]; //env assert(isvector(pv[4]));
POPN(1); pv[5] = Stack[SP-1]; // env
Stack[SP-1] = v; POPN(1);
Stack[SP-1] = tagptr(pv, TAG_CVALUE);
} }
break; 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) static void lisp_init(void)
{ {
int i; int i;
@ -2198,7 +2270,7 @@ static void lisp_init(void)
FL_T = builtin(F_TRUE); FL_T = builtin(F_TRUE);
FL_F = builtin(F_FALSE); FL_F = builtin(F_FALSE);
LAMBDA = symbol("lambda"); LAMBDA = symbol("lambda");
COMPILEDLAMBDA = symbol("compiled-lambda"); FUNCTION = symbol("function");
QUOTE = symbol("quote"); QUOTE = symbol("quote");
TRYCATCH = symbol("trycatch"); TRYCATCH = symbol("trycatch");
BACKQUOTE = symbol("backquote"); BACKQUOTE = symbol("backquote");
@ -2259,8 +2331,6 @@ static void lisp_init(void)
#endif #endif
cvalues_init(); cvalues_init();
set(symbol("gensym"), cbuiltin("gensym", gensym));
set(symbol("hash"), cbuiltin("hash", fl_hash));
char buf[1024]; char buf[1024];
char *exename = get_exename(buf, sizeof(buf)); char *exename = get_exename(buf, sizeof(buf));
@ -2273,6 +2343,11 @@ static void lisp_init(void)
memory_exception_value = list2(MemoryError, memory_exception_value = list2(MemoryError,
cvalue_static_cstring("out of memory")); 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(); builtins_init();
} }

8
femtolisp/flisp.h
View File

@ -93,6 +93,8 @@ typedef struct _symbol_t {
(((unsigned char*)ptr(v)) < fromspace+heapsize)) (((unsigned char*)ptr(v)) < fromspace+heapsize))
#define isgensym(x) (issymbol(x) && ismanaged(x)) #define isgensym(x) (issymbol(x) && ismanaged(x))
#define isfunction(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==functiontype))
extern value_t *Stack; extern value_t *Stack;
extern uint32_t SP; extern uint32_t SP;
#define PUSH(v) (Stack[SP++] = (v)) #define PUSH(v) (Stack[SP++] = (v))
@ -223,6 +225,12 @@ typedef struct {
char _space[1]; char _space[1];
} cprim_t; } cprim_t;
typedef struct {
value_t bcode;
value_t vals;
value_t env;
} function_t;
#define CPRIM_NWORDS 2 #define CPRIM_NWORDS 2
#define MAX_INL_SIZE 96 #define MAX_INL_SIZE 96

6
femtolisp/read.c
View File

@ -551,8 +551,10 @@ static value_t do_read_sexpr(value_t label)
} }
PUSH(NIL); PUSH(NIL);
read_list(&Stack[SP-1], UNBOUND); read_list(&Stack[SP-1], UNBOUND);
v = POP(); v = symbol_value(sym);
return apply(toplevel_eval(sym), v); if (v == UNBOUND)
raise(list2(UnboundError, sym));
return apply(v, POP());
case TOK_OPENB: case TOK_OPENB:
return read_vector(label, TOK_CLOSEB); return read_vector(label, TOK_CLOSEB);
case TOK_SHARPOPEN: case TOK_SHARPOPEN:

4
femtolisp/system.lsp
View File

@ -102,8 +102,8 @@
(define (char? x) (eq? (typeof x) 'wchar)) (define (char? x) (eq? (typeof x) 'wchar))
(define (function? x) (define (function? x)
(or (builtin? x) (or (builtin? x)
(and (pair? x) (or (eq (car x) 'lambda) (eq (typeof x) 'function)
(eq (car x) 'compiled-lambda))))) (and (pair? x) (eq (car x) 'lambda))))
(define procedure? function?) (define procedure? function?)
(define (caar x) (car (car x))) (define (caar x) (car (car x)))

2
femtolisp/todo
View File

@ -1018,7 +1018,7 @@ typedef struct _fltype_t {
new evaluator todo: new evaluator todo:
* need builtin = to handle nans properly, fix equal? on nans * 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 fields: signature, maxstack, bcode, vals, cloenv
function->vector function->vector
* make (for ...) a special form * make (for ...) a special form