conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

cleaning up implementation of apply() entry point 

removing use of interpreter in computed calls to builtins
This commit is contained in:
JeffBezanson 2009-04-17 03:40:52 +00:00
parent 94814a2e34
commit 86b7738c89
5 changed files with 88 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
femtolisp/compiler.lsp
View File

@ -9,7 +9,7 @@
(define Instructions (define Instructions
(make-enum-table (make-enum-table
[:nop :dup :pop :call :tcall :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 :for :tapply
:eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol? :eq? :eqv? :equal? :atom? :not :null? :boolean? :symbol?
:number? :bound? :pair? :builtin? :vector? :fixnum? :number? :bound? :pair? :builtin? :vector? :fixnum?
@ -25,7 +25,7 @@
:loadg :loada :loadc :loadg.l :loadg :loada :loadc :loadg.l
:setg :seta :setc :setg.l :setg :seta :setc :setg.l
:closure :trycatch :argc :vargc :close :let])) :closure :trycatch :argc :vargc :close :let :for]))
(define arg-counts (define arg-counts
(table :eq? 2 :eqv? 2 (table :eq? 2 :eqv? 2

130
femtolisp/flisp.c
View File

@ -55,7 +55,7 @@
static char *builtin_names[] = static char *builtin_names[] =
{ // special forms { // special forms
"quote", "cond", "if", "and", "or", "while", "lambda", "quote", "cond", "if", "and", "or", "while", "lambda",
"trycatch", "%apply", "%applyn", "set!", "prog1", "for", "begin", "trycatch", "%apply", "set!", "prog1", "for", "begin",
// predicates // predicates
"eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?", "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
@ -74,6 +74,16 @@ static char *builtin_names[] =
"vector", "aref", "aset!", "vector", "aref", "aset!",
"", "", "" }; "", "", "" };
#define ANYARGS -10000
static short builtin_arg_counts[] =
{ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
2, ANYARGS, 1, 1, 2, 2,
1, 2,
ANYARGS, -1, ANYARGS, -1, 2, 2, 2,
ANYARGS, 2, 3 };
#define N_STACK 262144 #define N_STACK 262144
value_t StaticStack[N_STACK]; value_t StaticStack[N_STACK];
value_t *Stack = StaticStack; value_t *Stack = StaticStack;
@ -467,7 +477,7 @@ static void trace_globals(symbol_t *root)
} }
} }
static value_t special_apply_form, special_applyn_form; static value_t special_apply_form;
static value_t apply1_args; static value_t apply1_args;
static value_t memory_exception_value; static value_t memory_exception_value;
@ -502,7 +512,6 @@ void gc(int mustgrow)
} }
lasterror = relocate(lasterror); lasterror = relocate(lasterror);
special_apply_form = relocate(special_apply_form); special_apply_form = relocate(special_apply_form);
special_applyn_form = relocate(special_applyn_form);
apply1_args = relocate(apply1_args); apply1_args = relocate(apply1_args);
memory_exception_value = relocate(memory_exception_value); memory_exception_value = relocate(memory_exception_value);
@ -541,22 +550,32 @@ void gc(int mustgrow)
// utils ---------------------------------------------------------------------- // utils ----------------------------------------------------------------------
value_t apply(value_t f, value_t l) #define topeval(e, env) (selfevaluating(e) ? (e) : eval_sexpr((e),env,1,2))
// apply function with n args on the stack
static value_t _applyn(uint32_t n)
{ {
PUSH(f); PUSH(fixnum(n));
PUSH(l); return topeval(special_apply_form, NULL);
value_t v = toplevel_eval(special_apply_form);
POPN(2);
return v;
} }
value_t apply1(value_t f, value_t a0) value_t apply(value_t f, value_t l)
{ {
value_t v = l;
uint32_t n = SP;
PUSH(f); PUSH(f);
PUSH(a0); while (iscons(v)) {
PUSH(fixnum(1)); if (n == MAX_ARGS) {
value_t v = toplevel_eval(special_applyn_form); PUSH(v);
POPN(3); break;
}
PUSH(car_(v));
v = cdr_(v);
}
n = SP - n - 1;
v = _applyn(n);
POPN(n+1);
return v; return v;
} }
@ -571,9 +590,8 @@ value_t applyn(uint32_t n, value_t f, ...)
value_t a = va_arg(ap, value_t); value_t a = va_arg(ap, value_t);
PUSH(a); PUSH(a);
} }
PUSH(fixnum(n)); value_t v = _applyn(n);
value_t v = toplevel_eval(special_applyn_form); POPN(n+1);
POPN(n+2);
return v; return v;
} }
@ -682,7 +700,6 @@ static value_t list(value_t *args, uint32_t nargs)
} }
#define eval(e) (selfevaluating(e) ? (e) : eval_sexpr((e),penv,0,envsz)) #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 { \ #define tail_eval(xpr) do { \
if (selfevaluating(xpr)) { SP=saveSP; return (xpr); } \ if (selfevaluating(xpr)) { SP=saveSP; return (xpr); } \
else { e=(xpr); goto eval_top; } } while (0) else { e=(xpr); goto eval_top; } } while (0)
@ -763,7 +780,7 @@ static value_t do_trycatch(value_t expr, value_t *penv, uint32_t envsz)
else { else {
v = car_(v); v = car_(v);
Stack[SP-1] = eval(v); Stack[SP-1] = eval(v);
v = apply1(Stack[SP-1], lasterror); v = applyn(1, Stack[SP-1], lasterror);
} }
} }
return v; return v;
@ -1387,21 +1404,15 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
penv = &Stack[SP-2]; penv = &Stack[SP-2];
} }
goto eval_top; goto eval_top;
case F_SPECIAL_APPLYN: case F_SPECIAL_APPLY:
POPN(4); POPN(2);
v = POP(); v = POP();
saveSP = SP;
nargs = numval(v); nargs = numval(v);
bp = SP-nargs-2; bp = SP-nargs-2;
f = Stack[bp+1]; f = Stack[bp+1];
penv = &Stack[bp+1]; penv = &Stack[bp+1];
goto do_apply; goto do_apply;
case F_SPECIAL_APPLY:
f = Stack[bp-4];
v = Stack[bp-3];
PUSH(f);
PUSH(v);
nargs = 2;
// falls through!!
case F_APPLY: case F_APPLY:
argcount("apply", nargs, 2); argcount("apply", nargs, 2);
v = Stack[SP-1]; // second arg is new arglist v = Stack[SP-1]; // second arg is new arglist
@ -1429,7 +1440,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
return v; return v;
} }
f = Stack[bp+1]; f = Stack[bp+1];
assert(SP > bp+1); assert((signed)SP > (signed)bp+1);
if (__likely(iscons(f))) { if (__likely(iscons(f))) {
if (car_(f) == COMPILEDLAMBDA) { if (car_(f) == COMPILEDLAMBDA) {
i = SP; i = SP;
@ -1535,10 +1546,10 @@ 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)
{ {
uint32_t i, n, ip, bp, envsz, captured; uint32_t i, n, ip, bp, envsz, captured, op;
fixnum_t s, lo, hi; fixnum_t s, lo, hi;
int64_t accum; int64_t accum;
uint8_t op, *code; uint8_t *code;
value_t func, v, bcode, x, e; value_t func, v, bcode, x, e;
value_t *pvals, *lenv, *pv; value_t *pvals, *lenv, *pv;
symbol_t *sym; symbol_t *sym;
@ -1615,12 +1626,31 @@ static value_t apply_cl(uint32_t nargs)
s = SP; s = SP;
func = Stack[SP-i-1]; func = Stack[SP-i-1];
if (isbuiltinish(func)) { if (isbuiltinish(func)) {
if (uintval(func) > N_BUILTINS) { op = uintval(func);
if (op > N_BUILTINS) {
v = ((builtin_t)ptr(func))(&Stack[SP-i], i); v = ((builtin_t)ptr(func))(&Stack[SP-i], i);
} }
else { else {
PUSH(fixnum(i)); s = builtin_arg_counts[op];
v = toplevel_eval(special_applyn_form); if (s >= 0)
argcount(builtin_names[op], i, s);
else if (s != ANYARGS && (signed)i < -s)
argcount(builtin_names[op], i, -s);
// remove function arg
for(s=SP-i-1; s < (int)SP-1; s++)
Stack[s] = Stack[s+1];
SP--;
n = i;
switch (op) {
case OP_LIST: goto apply_list;
case OP_ADD: goto apply_add;
case OP_SUB: goto apply_sub;
case OP_MUL: goto apply_mul;
case OP_DIV: goto apply_div;
case OP_VECTOR: goto apply_vector;
default:
goto dispatch;
}
} }
} }
else if (iscons(func)) { else if (iscons(func)) {
@ -1637,8 +1667,7 @@ static value_t apply_cl(uint32_t nargs)
} }
} }
else { else {
PUSH(fixnum(i)); v = _applyn(i);
v = toplevel_eval(special_applyn_form);
} }
} }
else { else {
@ -1755,6 +1784,7 @@ static value_t apply_cl(uint32_t nargs)
POPN(1); break; POPN(1); break;
case OP_LIST: case OP_LIST:
i = code[ip++]; i = code[ip++];
apply_list:
if (i > 0) if (i > 0)
v = list(&Stack[SP-i], i); v = list(&Stack[SP-i], i);
else else
@ -1784,8 +1814,9 @@ static value_t apply_cl(uint32_t nargs)
goto do_call; goto do_call;
case OP_ADD: case OP_ADD:
s = 0;
n = code[ip++]; n = code[ip++];
apply_add:
s = 0;
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++) {
@ -1809,6 +1840,7 @@ static value_t apply_cl(uint32_t nargs)
break; break;
case OP_SUB: case OP_SUB:
n = code[ip++]; n = code[ip++];
apply_sub:
if (__unlikely(n < 1)) lerror(ArgError, "-: too few arguments"); if (__unlikely(n < 1)) lerror(ArgError, "-: too few arguments");
i = SP-n; i = SP-n;
if (n == 1) { if (n == 1) {
@ -1845,8 +1877,9 @@ static value_t apply_cl(uint32_t nargs)
PUSH(v); PUSH(v);
break; break;
case OP_MUL: case OP_MUL:
accum = 1;
n = code[ip++]; n = code[ip++];
apply_mul:
accum = 1;
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++) {
@ -1870,6 +1903,7 @@ static value_t apply_cl(uint32_t nargs)
break; break;
case OP_DIV: case OP_DIV:
n = code[ip++]; n = code[ip++];
apply_div:
if (__unlikely(n < 1)) lerror(ArgError, "/: too few arguments"); if (__unlikely(n < 1)) lerror(ArgError, "/: too few arguments");
i = SP-n; i = SP-n;
if (n == 1) { if (n == 1) {
@ -1916,19 +1950,20 @@ static value_t apply_cl(uint32_t nargs)
case OP_VECTOR: case OP_VECTOR:
n = code[ip++]; n = code[ip++];
apply_vector:
if (n > MAX_ARGS) { if (n > MAX_ARGS) {
i = llength(Stack[SP-1]); i = llength(Stack[SP-1])-1;
n--;
} }
else i = 0; else i = 0;
v = alloc_vector(n+i, 0); v = alloc_vector(n+i, 0);
memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t)); memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t));
if (i > 0) { e = POP();
e = POP(); POPN(n-1);
POPN(n); if (n > MAX_ARGS) {
i = n-1;
while (iscons(e)) { while (iscons(e)) {
vector_elt(v,n) = car_(e); vector_elt(v,i) = car_(e);
n++; i++;
e = cdr_(e); e = cdr_(e);
} }
} }
@ -2200,11 +2235,10 @@ static void lisp_init(void)
set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH)); set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
lasterror = NIL; lasterror = NIL;
special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), 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); apply1_args = fl_cons(NIL, NIL);
i = 0; i = 0;
while (isspecial(builtin(i))) { while (isspecial(builtin(i))) {
if (i != F_SPECIAL_APPLY && i != F_SPECIAL_APPLYN) if (i != F_SPECIAL_APPLY)
((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i); ((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
i++; i++;
} }
@ -2304,7 +2338,7 @@ int main(int argc, char *argv[])
PUSH(symbol_value(symbol("__start"))); PUSH(symbol_value(symbol("__start")));
PUSH(argv_list(argc, argv)); PUSH(argv_list(argc, argv));
(void)toplevel_eval(special_apply_form); (void)_applyn(1);
} }
FL_CATCH { FL_CATCH {
ios_puts("fatal error during bootstrap:\n", ios_stderr); ios_puts("fatal error during bootstrap:\n", ios_stderr);

4
femtolisp/flisp.h
View File

@ -117,8 +117,7 @@ extern uint32_t SP;
enum { enum {
// special forms // special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
F_TRYCATCH, F_SPECIAL_APPLY, F_SPECIAL_APPLYN, F_SETQ, F_PROG1, F_FOR, F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROG1, F_FOR, F_BEGIN,
F_BEGIN,
// functions // functions
F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP, F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
@ -141,7 +140,6 @@ value_t read_sexpr(value_t f);
void print(ios_t *f, value_t v, int princ); void print(ios_t *f, value_t v, int princ);
value_t toplevel_eval(value_t expr); value_t toplevel_eval(value_t expr);
value_t apply(value_t f, value_t l); 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 applyn(uint32_t n, value_t f, ...);
value_t load_file(char *fname); value_t load_file(char *fname);

4
femtolisp/opcodes.h
View File

@ -3,7 +3,7 @@
enum { enum {
OP_NOP=0, OP_DUP, OP_POP, OP_CALL, OP_TCALL, OP_JMP, OP_BRF, OP_BRT, 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_FOR, 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_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_SYMBOLP, OP_NUMBERP, OP_BOUNDP, OP_PAIRP, OP_BUILTINP, OP_VECTORP,
@ -20,7 +20,7 @@ enum {
OP_LOADV, OP_LOADVL, OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL, OP_LOADV, OP_LOADVL, OP_LOADG, OP_LOADA, OP_LOADC, OP_LOADGL,
OP_SETG, OP_SETA, OP_SETC, OP_SETGL, OP_SETG, OP_SETA, OP_SETC, OP_SETGL,
OP_CLOSURE, OP_TRYCATCH, OP_ARGC, OP_VARGC, OP_CLOSE, OP_LET OP_CLOSURE, OP_TRYCATCH, OP_ARGC, OP_VARGC, OP_CLOSE, OP_LET, OP_FOR
}; };
#endif #endif

2
femtolisp/system.lsp
View File

@ -735,7 +735,7 @@
(lambda (e) (begin (print-exception e) (lambda (e) (begin (print-exception e)
(exit 1))))) (exit 1)))))
(define (__start . argv) (define (__start argv)
; reload this file with our new definition of load ; reload this file with our new definition of load
(load (string *install-dir* *directory-separator* "system.lsp")) (load (string *install-dir* *directory-separator* "system.lsp"))
(if (pair? (cdr argv)) (if (pair? (cdr argv))