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

improving closure representation 

some performance tweaks
This commit is contained in:
JeffBezanson 2009-04-28 04:10:18 +00:00
parent 14d625bd83
commit 264df1f90b
7 changed files with 146 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
femtolisp/Makefile
View File

@ -12,7 +12,7 @@ FLAGS = -falign-functions -Wall -Wextra -Wno-strict-aliasing -I$(LLTDIR) $(CFLAG
LIBS = $(LLT) -lm LIBS = $(LLT) -lm
DEBUGFLAGS = -g -DDEBUG $(FLAGS) DEBUGFLAGS = -g -DDEBUG $(FLAGS)
SHIPFLAGS = -O3 -DNDEBUG -fomit-frame-pointer -mtune=generic -march=i686 $(FLAGS) SHIPFLAGS = -O3 -DNDEBUG -fomit-frame-pointer -march=native $(FLAGS)
default: release test default: release test

35
femtolisp/cvalues.c
View File

@ -635,12 +635,14 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs)
case TAG_NUM: return fixnumsym; case TAG_NUM: return fixnumsym;
case TAG_SYM: return symbolsym; case TAG_SYM: return symbolsym;
case TAG_VECTOR: return vectorsym; case TAG_VECTOR: return vectorsym;
case TAG_BUILTIN: case TAG_FUNCTION:
if (args[0] == FL_T || args[0] == FL_F) if (args[0] == FL_T || args[0] == FL_F)
return booleansym; return booleansym;
if (args[0] == NIL) if (args[0] == NIL)
return nullsym; return nullsym;
if (isbuiltin(args[0]))
return builtinsym; return builtinsym;
return FUNCTION;
} }
return cv_type((cvalue_t*)ptr(args[0])); return cv_type((cvalue_t*)ptr(args[0]));
} }
@ -877,31 +879,26 @@ value_t fl_builtin(value_t *args, u_int32_t nargs)
{ {
argcount("builtin", nargs, 1); argcount("builtin", nargs, 1);
symbol_t *name = tosymbol(args[0], "builtin"); symbol_t *name = tosymbol(args[0], "builtin");
builtin_t f; cvalue_t *cv;
if (ismanaged(args[0]) || (f=(builtin_t)name->dlcache) == NULL) { if (ismanaged(args[0]) || (cv=name->dlcache) == NULL) {
lerror(ArgError, "builtin: function not found"); lerror(ArgError, "builtin: function not found");
} }
return tagptr(f, TAG_BUILTIN); return tagptr(cv, TAG_CVALUE);
} }
value_t cbuiltin(char *name, builtin_t f) value_t cbuiltin(char *name, builtin_t f)
{ {
assert(((uptrint_t)f & 0x7) == 0); cvalue_t *cv = (cvalue_t*)malloc(CVALUE_NWORDS * sizeof(value_t));
cv->type = builtintype;
cv->data = &cv->_space[0];
cv->len = sizeof(value_t);
*(void**)cv->data = f;
value_t sym = symbol(name); value_t sym = symbol(name);
((symbol_t*)ptr(sym))->dlcache = f; ((symbol_t*)ptr(sym))->dlcache = cv;
ptrhash_put(&reverse_dlsym_lookup_table, f, (void*)sym); ptrhash_put(&reverse_dlsym_lookup_table, cv, (void*)sym);
return tagptr(f, TAG_BUILTIN);
/* return tagptr(cv, TAG_CVALUE);
value_t gf = cvalue(builtintype, sizeof(void*));
((cvalue_t*)ptr(gf))->data = f;
size_t nw = cv_nwords((cvalue_t*)ptr(gf));
// directly-callable values are assumed not to move for
// evaluator performance, so put builtin func metadata on the
// unmanaged heap
cvalue_t *buf = malloc(nw * sizeof(value_t));
memcpy(buf, ptr(gf), nw*sizeof(value_t));
return tagptr(buf, TAG_BUILTIN);
*/
} }
static value_t fl_logand(value_t *args, u_int32_t nargs); static value_t fl_logand(value_t *args, u_int32_t nargs);

15
femtolisp/equal.c
View File

@ -91,11 +91,16 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
return fixnum(c); return fixnum(c);
break; break;
case TAG_CVALUE: case TAG_CVALUE:
if (iscvalue(b)) if (iscvalue(b)) {
if (cv_isPOD((cvalue_t*)ptr(a)) && cv_isPOD((cvalue_t*)ptr(b)))
return cvalue_compare(a, b); return cvalue_compare(a, b);
return fixnum(1);
}
break; break;
case TAG_BUILTIN: case TAG_FUNCTION:
if (tagb == TAG_BUILTIN) { if (uintval(a) > N_BUILTINS || uintval(b) > N_BUILTINS)
return fixnum(1);
if (tagb == TAG_FUNCTION) {
return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1); return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
} }
break; break;
@ -267,7 +272,9 @@ static uptrint_t bounded_hash(value_t a, int bound)
case TAG_NUM1: case TAG_NUM1:
d = numval(a); d = numval(a);
return doublehash(*(int64_t*)&d); return doublehash(*(int64_t*)&d);
case TAG_BUILTIN: case TAG_FUNCTION:
if (uintval(a) > N_BUILTINS)
return bounded_hash(((function_t*)ptr(a))->bcode, bound);
return inthash(a); return inthash(a);
case TAG_SYM: case TAG_SYM:
return ((symbol_t*)ptr(a))->hash; return ((symbol_t*)ptr(a))->hash;

162
femtolisp/flisp.c
View File

@ -95,7 +95,6 @@ value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym; value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
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, evalsym; value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym;
static fltype_t *functiontype;
static value_t apply_cl(uint32_t nargs); static value_t apply_cl(uint32_t nargs);
static value_t *alloc_words(int n); static value_t *alloc_words(int n);
@ -203,7 +202,7 @@ void bounds_error(char *fname, value_t arr, value_t ind)
#define SAFECAST_OP(type,ctype,cnvt) \ #define SAFECAST_OP(type,ctype,cnvt) \
ctype to##type(value_t v, char *fname) \ ctype to##type(value_t v, char *fname) \
{ \ { \
if (__likely(is##type(v))) \ if (is##type(v)) \
return (ctype)cnvt(v); \ return (ctype)cnvt(v); \
type_error(fname, #type, v); \ type_error(fname, #type, v); \
} }
@ -437,6 +436,18 @@ static value_t relocate(value_t v)
else if (t == TAG_CVALUE) { else if (t == TAG_CVALUE) {
return cvalue_relocate(v); return cvalue_relocate(v);
} }
else if (t == TAG_FUNCTION) {
function_t *fn = (function_t*)ptr(v);
function_t *nfn = (function_t*)alloc_words(4);
nfn->bcode = fn->bcode;
nfn->vals = fn->vals;
nc = tagptr(nfn, TAG_FUNCTION);
forward(v, nc);
nfn->env = relocate(fn->env);
nfn->vals = relocate(nfn->vals);
nfn->bcode = relocate(nfn->bcode);
return nc;
}
else if (t == TAG_SYM) { else if (t == TAG_SYM) {
gensym_t *gs = (gensym_t*)ptr(v); gensym_t *gs = (gensym_t*)ptr(v);
gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*)); gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
@ -541,19 +552,17 @@ static value_t _applyn(uint32_t n)
value_t f = Stack[SP-n-1]; value_t f = Stack[SP-n-1];
uint32_t saveSP = SP; uint32_t saveSP = SP;
value_t v; value_t v;
if (isbuiltinish(f)) { if (iscbuiltin(f)) {
if (uintval(f) > N_BUILTINS) { v = ((builtin_t*)ptr(f))[3](&Stack[SP-n], n);
v = ((builtin_t)ptr(f))(&Stack[SP-n], n);
SP = saveSP;
return v;
}
} }
else if (isfunction(f)) { else if (isfunction(f)) {
v = apply_cl(n); v = apply_cl(n);
}
else {
type_error("apply", "function", f);
}
SP = saveSP; SP = saveSP;
return v; return v;
}
type_error("apply", "function", f);
} }
value_t apply(value_t f, value_t l) value_t apply(value_t f, value_t l)
@ -716,7 +725,9 @@ static value_t do_trycatch()
return v; return v;
} }
#define fn_vals(f) (((value_t*)ptr(f))[4]) #define fn_bcode(f) (((value_t*)ptr(f))[0])
#define fn_vals(f) (((value_t*)ptr(f))[1])
#define fn_env(f) (((value_t*)ptr(f))[2])
/* /*
stack on entry: <func> <args...> stack on entry: <func> <args...>
@ -745,7 +756,6 @@ static value_t apply_cl(uint32_t nargs)
int64_t accum; int64_t accum;
uint8_t *code; uint8_t *code;
value_t func, v, x, e; value_t func, v, x, e;
function_t *fn;
value_t *lenv, *pv; value_t *lenv, *pv;
symbol_t *sym; symbol_t *sym;
cons_t *c; cons_t *c;
@ -753,16 +763,12 @@ 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];
fn = value2c(function_t*,func); code = cv_data((cvalue_t*)ptr(fn_bcode(func)));
code = cv_data((cvalue_t*)ptr(fn->bcode));
assert(!ismanaged((uptrint_t)code)); assert(!ismanaged((uptrint_t)code));
assert(ismanaged(func)); assert(ismanaged(func));
assert(ismanaged(fn->bcode));
if (nargs < code[1])
lerror(ArgError, "apply: too few arguments");
bp = SP-nargs; bp = SP-nargs;
PUSH(fn->env); PUSH(fn_env(func));
ip = 0; ip = 0;
{ {
@ -771,8 +777,12 @@ static value_t apply_cl(uint32_t nargs)
dispatch: dispatch:
switch (op) { switch (op) {
case OP_ARGC: case OP_ARGC:
if (nargs > code[ip++]) { n = code[ip++];
if (nargs != n) {
if (nargs > n)
lerror(ArgError, "apply: too many arguments"); lerror(ArgError, "apply: too many arguments");
else
lerror(ArgError, "apply: too few arguments");
} }
goto next_op; goto next_op;
case OP_VARGC: case OP_VARGC:
@ -788,6 +798,9 @@ static value_t apply_cl(uint32_t nargs)
Stack[bp+i] = v; Stack[bp+i] = v;
Stack[bp+i+1] = Stack[bp+nargs]; Stack[bp+i+1] = Stack[bp+nargs];
} }
else if (s < 0) {
lerror(ArgError, "apply: too few arguments");
}
else { else {
PUSH(NIL); PUSH(NIL);
Stack[SP-1] = Stack[SP-2]; Stack[SP-1] = Stack[SP-2];
@ -819,15 +832,12 @@ static value_t apply_cl(uint32_t nargs)
do_call: do_call:
func = Stack[SP-n-1]; func = Stack[SP-n-1];
s = SP; s = SP;
if (isfunction(func)) { if (tag(func) == TAG_FUNCTION) {
if (func > (N_BUILTINS<<3)) {
v = apply_cl(n); v = apply_cl(n);
} }
else if (isbuiltinish(func)) {
op = uintval(func);
if (op > N_BUILTINS) {
v = ((builtin_t)ptr(func))(&Stack[SP-n], n);
}
else { else {
op = uintval(func);
if (op > OP_ASET) if (op > OP_ASET)
type_error("apply", "function", func); type_error("apply", "function", func);
s = builtin_arg_counts[op]; s = builtin_arg_counts[op];
@ -851,6 +861,9 @@ static value_t apply_cl(uint32_t nargs)
} }
} }
} }
else if (iscbuiltin(func)) {
v = (((builtin_t*)ptr(func))[3])(&Stack[SP-n], n);
}
else { else {
type_error("apply", "function", func); type_error("apply", "function", func);
} }
@ -892,8 +905,7 @@ static value_t apply_cl(uint32_t nargs)
v = FL_F; v = FL_F;
} }
else { else {
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? v = equal(Stack[SP-2], Stack[SP-1]);
FL_T : FL_F;
} }
Stack[SP-2] = v; POPN(1); Stack[SP-2] = v; POPN(1);
goto next_op; goto next_op;
@ -901,12 +913,8 @@ static value_t apply_cl(uint32_t nargs)
if (Stack[SP-2] == Stack[SP-1]) { if (Stack[SP-2] == Stack[SP-1]) {
v = FL_T; v = FL_T;
} }
else if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
v = FL_F;
}
else { else {
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? v = equal(Stack[SP-2], Stack[SP-1]);
FL_T : FL_F;
} }
Stack[SP-2] = v; POPN(1); Stack[SP-2] = v; POPN(1);
goto next_op; goto next_op;
@ -920,12 +928,12 @@ static value_t apply_cl(uint32_t nargs)
Stack[SP-1] = ((Stack[SP-1]==NIL) ? FL_T : FL_F); goto next_op; Stack[SP-1] = ((Stack[SP-1]==NIL) ? FL_T : FL_F); goto next_op;
case OP_BOOLEANP: case OP_BOOLEANP:
v = Stack[SP-1]; v = Stack[SP-1];
Stack[SP-1] = ((v == FL_T || v == FL_F) ? FL_T : FL_F); goto next_op; Stack[SP-1] = ((v == FL_T || v == FL_F) ? FL_T:FL_F); goto next_op;
case OP_SYMBOLP: case OP_SYMBOLP:
Stack[SP-1] = (issymbol(Stack[SP-1]) ? FL_T : FL_F); goto next_op; Stack[SP-1] = (issymbol(Stack[SP-1]) ? FL_T : FL_F); goto next_op;
case OP_NUMBERP: case OP_NUMBERP:
v = Stack[SP-1]; v = Stack[SP-1];
Stack[SP-1] = (isfixnum(v) || iscprim(v) ? FL_T : FL_F); goto next_op; Stack[SP-1] = (isfixnum(v) || iscprim(v) ? FL_T:FL_F); goto next_op;
case OP_FIXNUMP: case OP_FIXNUMP:
Stack[SP-1] = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); goto next_op; Stack[SP-1] = (isfixnum(Stack[SP-1]) ? FL_T : FL_F); goto next_op;
case OP_BOUNDP: case OP_BOUNDP:
@ -934,13 +942,12 @@ static value_t apply_cl(uint32_t nargs)
goto next_op; goto next_op;
case OP_BUILTINP: case OP_BUILTINP:
v = Stack[SP-1]; v = Stack[SP-1];
Stack[SP-1] = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL) Stack[SP-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL_T : FL_F;
? FL_T : FL_F);
goto next_op; goto next_op;
case OP_FUNCTIONP: case OP_FUNCTIONP:
v = Stack[SP-1]; v = Stack[SP-1];
Stack[SP-1] = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL) || Stack[SP-1] = ((tag(v)==TAG_FUNCTION &&v!=FL_F&&v!=FL_T&&v!=NIL) ||
isfunction(v)) ? FL_T : FL_F; iscbuiltin(v)) ? FL_T : FL_F;
goto next_op; goto next_op;
case OP_VECTORP: case OP_VECTORP:
Stack[SP-1] = (isvector(Stack[SP-1]) ? FL_T : FL_F); goto next_op; Stack[SP-1] = (isvector(Stack[SP-1]) ? FL_T : FL_F); goto next_op;
@ -1006,9 +1013,9 @@ static value_t apply_cl(uint32_t nargs)
i = SP-n; i = SP-n;
if (n > MAX_ARGS) goto add_ovf; if (n > MAX_ARGS) goto add_ovf;
for (; i < SP; i++) { for (; i < SP; i++) {
if (__likely(isfixnum(Stack[i]))) { if (isfixnum(Stack[i])) {
s += numval(Stack[i]); s += numval(Stack[i]);
if (__unlikely(!fits_fixnum(s))) { if (!fits_fixnum(s)) {
i++; i++;
goto add_ovf; goto add_ovf;
} }
@ -1056,16 +1063,16 @@ static value_t apply_cl(uint32_t nargs)
goto next_op; goto next_op;
case OP_NEG: case OP_NEG:
do_neg: do_neg:
if (__likely(isfixnum(Stack[SP-1]))) if (isfixnum(Stack[SP-1]))
Stack[SP-1] = fixnum(-numval(Stack[SP-1])); Stack[SP-1] = fixnum(-numval(Stack[SP-1]));
else else
Stack[SP-1] = fl_neg(Stack[SP-1]); Stack[SP-1] = fl_neg(Stack[SP-1]);
goto next_op; goto next_op;
case OP_SUB2: case OP_SUB2:
do_sub2: do_sub2:
if (__likely(bothfixnums(Stack[SP-2], Stack[SP-1]))) { if (bothfixnums(Stack[SP-2], Stack[SP-1])) {
s = numval(Stack[SP-2]) - numval(Stack[SP-1]); s = numval(Stack[SP-2]) - numval(Stack[SP-1]);
if (__likely(fits_fixnum(s))) if (fits_fixnum(s))
v = fixnum(s); v = fixnum(s);
else else
v = mk_long(s); v = mk_long(s);
@ -1084,7 +1091,7 @@ static value_t apply_cl(uint32_t nargs)
i = SP-n; i = SP-n;
if (n > MAX_ARGS) goto mul_ovf; if (n > MAX_ARGS) goto mul_ovf;
for (; i < SP; i++) { for (; i < SP; i++) {
if (__likely(isfixnum(Stack[i]))) { if (isfixnum(Stack[i])) {
accum *= numval(Stack[i]); accum *= numval(Stack[i]);
} }
else { else {
@ -1094,7 +1101,7 @@ static value_t apply_cl(uint32_t nargs)
} }
} }
if (i == SP) { if (i == SP) {
if (__likely(fits_fixnum(accum))) if (fits_fixnum(accum))
v = fixnum(accum); v = fixnum(accum);
else else
v = return_from_int64(accum); v = return_from_int64(accum);
@ -1176,7 +1183,7 @@ static value_t apply_cl(uint32_t nargs)
v = Stack[SP-2]; v = Stack[SP-2];
if (isvector(v)) { if (isvector(v)) {
i = tofixnum(Stack[SP-1], "aref"); i = tofixnum(Stack[SP-1], "aref");
if (__unlikely((unsigned)i >= vector_size(v))) if ((unsigned)i >= vector_size(v))
bounds_error("aref", v, Stack[SP-1]); bounds_error("aref", v, Stack[SP-1]);
v = vector_elt(v, i); v = vector_elt(v, i);
} }
@ -1193,7 +1200,7 @@ static value_t apply_cl(uint32_t nargs)
e = Stack[SP-3]; e = Stack[SP-3];
if (isvector(e)) { if (isvector(e)) {
i = tofixnum(Stack[SP-2], "aset!"); i = tofixnum(Stack[SP-2], "aset!");
if (__unlikely((unsigned)i >= vector_size(e))) if ((unsigned)i >= vector_size(e))
bounds_error("aset!", v, Stack[SP-1]); bounds_error("aset!", v, Stack[SP-1]);
vector_elt(e, i) = (v=Stack[SP-1]); vector_elt(e, i) = (v=Stack[SP-1]);
} }
@ -1339,17 +1346,14 @@ 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) {
pv = alloc_words(6); pv = alloc_words(4);
x = Stack[SP-2]; // closure to copy x = Stack[SP-2]; // closure to copy
assert(isfunction(x)); assert(isfunction(x));
pv[0] = ((value_t*)ptr(x))[0]; pv[0] = ((value_t*)ptr(x))[0];
pv[1] = (value_t)&pv[3]; pv[1] = ((value_t*)ptr(x))[1];
pv[2] = ((value_t*)ptr(x))[2]; pv[2] = Stack[SP-1]; // env
pv[3] = ((value_t*)ptr(x))[3];
pv[4] = ((value_t*)ptr(x))[4];
pv[5] = Stack[SP-1]; // env
POPN(1); POPN(1);
Stack[SP-1] = tagptr(pv, TAG_CVALUE); Stack[SP-1] = tagptr(pv, TAG_FUNCTION);
} }
goto next_op; goto next_op;
@ -1379,42 +1383,6 @@ 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);
char *data = cvalue_data(fn->bcode);
size_t i, sz = cvalue_len(fn->bcode);
for(i=0; i < sz; i++) data[i] += 48;
fl_print_child(f, fn->bcode, 0);
for(i=0; i < sz; i++) data[i] -= 48;
outc(' ', f);
fl_print_child(f, fn->vals, 0);
if (fn->env != NIL) {
outc(' ', 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) static value_t fl_function(value_t *args, uint32_t nargs)
{ {
if (nargs != 3) if (nargs != 3)
@ -1432,8 +1400,8 @@ static value_t fl_function(value_t *args, uint32_t nargs)
for(i=0; i < sz; i++) for(i=0; i < sz; i++)
data[i] -= 48; data[i] -= 48;
} }
value_t fv = cvalue(functiontype, sizeof(function_t)); function_t *fn = (function_t*)alloc_words(4);
function_t *fn = value2c(function_t*,fv); value_t fv = tagptr(fn, TAG_FUNCTION);
fn->bcode = args[0]; fn->bcode = args[0];
fn->vals = args[1]; fn->vals = args[1];
if (nargs == 3) if (nargs == 3)
@ -1447,19 +1415,16 @@ static value_t fl_function2vector(value_t *args, uint32_t nargs)
{ {
argcount("function->vector", nargs, 1); argcount("function->vector", nargs, 1);
value_t v = args[0]; value_t v = args[0];
if (!iscvalue(v) || cv_class((cvalue_t*)ptr(v)) != functiontype) if (!isclosure(v))
type_error("function->vector", "function", v); type_error("function->vector", "function", v);
value_t vec = alloc_vector(3, 0); value_t vec = alloc_vector(3, 0);
function_t *fn = value2c(function_t*,args[0]); function_t *fn = (function_t*)ptr(args[0]);
vector_elt(vec,0) = fn->bcode; vector_elt(vec,0) = fn->bcode;
vector_elt(vec,1) = fn->vals; vector_elt(vec,1) = fn->vals;
vector_elt(vec,2) = fn->env; vector_elt(vec,2) = fn->env;
return vec; return vec;
} }
static cvtable_t function_vtable = { print_function, relocate_function,
NULL, print_traverse_function };
static builtinspec_t core_builtin_info[] = { static builtinspec_t core_builtin_info[] = {
{ "function", fl_function }, { "function", fl_function },
{ "function->vector", fl_function2vector }, { "function->vector", fl_function2vector },
@ -1557,9 +1522,6 @@ static void lisp_init(void)
the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR); the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR);
vector_setsize(the_empty_vector, 0); vector_setsize(the_empty_vector, 0);
functiontype = define_opaque_type(FUNCTION, sizeof(function_t),
&function_vtable, NULL);
assign_global_builtins(core_builtin_info); assign_global_builtins(core_builtin_info);
builtins_init(); builtins_init();

13
femtolisp/flisp.h
View File

@ -31,7 +31,7 @@ typedef struct _symbol_t {
#define TAG_NUM 0x0 #define TAG_NUM 0x0
#define TAG_CPRIM 0x1 #define TAG_CPRIM 0x1
#define TAG_BUILTIN 0x2 #define TAG_FUNCTION 0x2
#define TAG_VECTOR 0x3 #define TAG_VECTOR 0x3
#define TAG_NUM1 0x4 #define TAG_NUM1 0x4
#define TAG_CVALUE 0x5 #define TAG_CVALUE 0x5
@ -52,13 +52,12 @@ typedef struct _symbol_t {
#endif #endif
#define fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0) #define fits_bits(x,b) (((x)>>(b-1)) == 0 || (~((x)>>(b-1))) == 0)
#define uintval(x) (((unsigned int)(x))>>3) #define uintval(x) (((unsigned int)(x))>>3)
#define builtin(n) tagptr((((int)n)<<3), TAG_BUILTIN) #define builtin(n) tagptr((((int)n)<<3), TAG_FUNCTION)
#define iscons(x) (tag(x) == TAG_CONS) #define iscons(x) (tag(x) == TAG_CONS)
#define issymbol(x) (tag(x) == TAG_SYM) #define issymbol(x) (tag(x) == TAG_SYM)
#define isfixnum(x) (((x)&3) == TAG_NUM) #define isfixnum(x) (((x)&3) == TAG_NUM)
#define bothfixnums(x,y) ((((x)|(y))&3) == TAG_NUM) #define bothfixnums(x,y) ((((x)|(y))&3) == TAG_NUM)
#define isbuiltin(x) ((tag(x) == TAG_BUILTIN) && uintval(x) < N_BUILTINS) #define isbuiltin(x) ((tag(x) == TAG_FUNCTION) && (x) < (OP_BOOL_CONST_T<<3))
#define isbuiltinish(x) (tag(x) == TAG_BUILTIN)
#define isvector(x) (tag(x) == TAG_VECTOR) #define isvector(x) (tag(x) == TAG_VECTOR)
#define iscvalue(x) (tag(x) == TAG_CVALUE) #define iscvalue(x) (tag(x) == TAG_CVALUE)
#define iscprim(x) (tag(x) == TAG_CPRIM) #define iscprim(x) (tag(x) == TAG_CPRIM)
@ -93,7 +92,9 @@ 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)) #define isfunction(x) (tag(x) == TAG_FUNCTION && (x) > (N_BUILTINS<<3))
#define isclosure(x) isfunction(x)
#define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype))
extern value_t *Stack; extern value_t *Stack;
extern uint32_t SP; extern uint32_t SP;
@ -105,6 +106,8 @@ extern uint32_t SP;
// the largest value nargs can have is MAX_ARGS+1 // the largest value nargs can have is MAX_ARGS+1
#define MAX_ARGS 127 #define MAX_ARGS 127
#include "opcodes.h"
// utility for iterating over all arguments in a builtin // utility for iterating over all arguments in a builtin
// i=index, i0=start index, arg = var for each arg, args = arg array // i=index, i0=start index, arg = var for each arg, args = arg array
// assumes "nargs" is the argument count // assumes "nargs" is the argument count

61
femtolisp/print.c
View File

@ -81,6 +81,13 @@ void print_traverse(value_t v)
else if (iscprim(v)) { else if (iscprim(v)) {
mark_cons(v); mark_cons(v);
} }
else if (isclosure(v)) {
mark_cons(v);
function_t *f = (function_t*)ptr(v);
print_traverse(f->bcode);
print_traverse(f->vals);
print_traverse(f->env);
}
else { else {
assert(iscvalue(v)); assert(iscvalue(v));
cvalue_t *cv = (cvalue_t*)ptr(v); cvalue_t *cv = (cvalue_t*)ptr(v);
@ -152,7 +159,7 @@ static inline int tinyp(value_t v)
return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN); return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN);
if (isstring(v)) if (isstring(v))
return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN); return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN);
return (isfixnum(v) || isbuiltinish(v)); return (isfixnum(v) || isbuiltin(v));
} }
static int smallp(value_t v) static int smallp(value_t v)
@ -351,35 +358,37 @@ void fl_print_child(ios_t *f, value_t v, int princ)
else else
print_symbol_name(f, name); print_symbol_name(f, name);
break; break;
case TAG_BUILTIN: case TAG_FUNCTION:
if (v == FL_T) { if (v == FL_T) {
outsn("#t", f, 2); outsn("#t", f, 2);
break;
} }
if (v == FL_F) { else if (v == FL_F) {
outsn("#f", f, 2); outsn("#f", f, 2);
break;
} }
if (v == NIL) { else if (v == NIL) {
outsn("()", f, 2); outsn("()", f, 2);
break;
} }
if (isbuiltin(v)) { else if (isbuiltin(v)) {
if (!princ) if (!princ)
outsn("#.", f, 2); outsn("#.", f, 2);
outs(builtin_names[uintval(v)], f); outs(builtin_names[uintval(v)], f);
break;
}
label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, ptr(v));
if (label == (value_t)HT_NOTFOUND) {
HPOS += ios_printf(f, "#<builtin @0x%08lx>",
(unsigned long)(builtin_t)ptr(v));
} }
else { else {
if (princ) assert(isclosure(v));
outs(symbol_name(label), f); function_t *fn = (function_t*)ptr(v);
else outs("#function(", f);
HPOS += ios_printf(f, "#builtin(%s)", symbol_name(label)); char *data = cvalue_data(fn->bcode);
size_t i, sz = cvalue_len(fn->bcode);
for(i=0; i < sz; i++) data[i] += 48;
fl_print_child(f, fn->bcode, 0);
for(i=0; i < sz; i++) data[i] -= 48;
outc(' ', f);
fl_print_child(f, fn->vals, 0);
if (fn->env != NIL) {
outc(' ', f);
fl_print_child(f, fn->env, 0);
}
outc(')', f);
} }
break; break;
case TAG_CVALUE: case TAG_CVALUE:
@ -423,6 +432,7 @@ void fl_print_child(ios_t *f, value_t v, int princ)
break; break;
} }
if (iscvalue(v) || iscprim(v)) { if (iscvalue(v) || iscprim(v)) {
if (ismanaged(v))
unmark_cons(v); unmark_cons(v);
cvalue_print(f, v, princ); cvalue_print(f, v, princ);
break; break;
@ -657,10 +667,21 @@ static void cvalue_print(ios_t *f, value_t v, int princ)
{ {
cvalue_t *cv = (cvalue_t*)ptr(v); cvalue_t *cv = (cvalue_t*)ptr(v);
void *data = cptr(v); void *data = cptr(v);
value_t label;
if (cv_class(cv) == builtintype) { if (cv_class(cv) == builtintype) {
HPOS+=ios_printf(f, "#<builtin @0x%08lx>", void *fptr = *(void**)data;
(unsigned long)(builtin_t)data); label = (value_t)ptrhash_get(&reverse_dlsym_lookup_table, cv);
if (label == (value_t)HT_NOTFOUND) {
HPOS += ios_printf(f, "#<builtin @0x%08lx>",
(unsigned long)(builtin_t)fptr);
}
else {
if (princ)
outs(symbol_name(label), f);
else
HPOS += ios_printf(f, "#builtin(%s)", symbol_name(label));
}
} }
else if (cv_class(cv)->vtable != NULL && else if (cv_class(cv)->vtable != NULL &&
cv_class(cv)->vtable->print != NULL) { cv_class(cv)->vtable->print != NULL) {

1
femtolisp/todo
View File

@ -1024,6 +1024,7 @@ new evaluator todo:
* make (for ...) a special form * make (for ...) a special form
* trycatch should require 2nd arg to be a lambda expression * trycatch should require 2nd arg to be a lambda expression
* immediate load int8 instruction * immediate load int8 instruction
- fix equal? on functions
- maxstack calculation, replace Stack with C stack, alloca - maxstack calculation, replace Stack with C stack, alloca
- stack traces and better debugging support - stack traces and better debugging support
- lambda lifting - lambda lifting