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

changing environment representation to contiguous values 

eliminating built-in label form
This commit is contained in:
JeffBezanson 2008-07-15 01:20:52 +00:00
parent 0d5cb73523
commit b76bbe3724
6 changed files with 158 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
femtolisp/ast/out.lsp
View File

File diff suppressed because one or more lines are too long

12
femtolisp/attic/trash.c
View File

@ -115,3 +115,15 @@ value_t fl_inv(value_t b)
inv_error: inv_error:
lerror(DivideError, "/: division by zero"); lerror(DivideError, "/: division by zero");
} }
static void printstack(value_t *penv, uint32_t envsz)
{
int i;
printf("env=%d, size=%d\n", penv - &Stack[0], envsz);
for(i=0; i < SP; i++) {
printf("%d: ", i);
print(stdout, Stack[i], 0);
printf("\n");
}
printf("\n");
}

257
femtolisp/flisp.c
View File

@ -68,7 +68,7 @@
#include "flisp.h" #include "flisp.h"
static char *builtin_names[] = static char *builtin_names[] =
{ "quote", "cond", "if", "and", "or", "while", "lambda", "label", { "quote", "cond", "if", "and", "or", "while", "lambda",
"trycatch", "progn", "trycatch", "progn",
"eq", "atom", "not", "symbolp", "numberp", "boundp", "consp", "eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
@ -84,13 +84,13 @@ static char *stack_bottom;
value_t Stack[N_STACK]; value_t Stack[N_STACK];
u_int32_t SP = 0; u_int32_t SP = 0;
value_t NIL, T, LAMBDA, LABEL, QUOTE, VECTOR, IF, TRYCATCH; value_t NIL, T, LAMBDA, QUOTE, VECTOR, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT; value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error; value_t DivideError, BoundsError, Error;
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend); static value_t eval_sexpr(value_t e, value_t *penv, int tail);
static value_t *alloc_words(int n); static value_t *alloc_words(int n);
static value_t relocate(value_t v); static value_t relocate(value_t v);
static void do_print(FILE *f, value_t v, int princ); static void do_print(FILE *f, value_t v, int princ);
@ -608,13 +608,13 @@ static value_t assoc(value_t item, value_t v)
return NIL; return NIL;
} }
#define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0,envend)) #define eval(e) ((tag(e)<0x2) ? (e) : eval_sexpr((e),penv,0))
#define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1,SP)) #define topeval(e, env) ((tag(e)<0x2) ? (e) : eval_sexpr((e),env,1))
#define tail_eval(xpr) do { SP = saveSP; \ #define tail_eval(xpr) do { SP = saveSP; \
if (tag(xpr)<0x2) { return (xpr); } \ if (tag(xpr)<0x2) { return (xpr); } \
else { e=(xpr); goto eval_top; } } while (0) else { e=(xpr); goto eval_top; } } while (0)
static value_t do_trycatch(value_t expr, value_t *penv, u_int32_t envend) static value_t do_trycatch(value_t expr, value_t *penv)
{ {
value_t v; value_t v;
@ -639,26 +639,27 @@ static value_t do_trycatch(value_t expr, value_t *penv, u_int32_t envend)
/* stack setup on entry: /* stack setup on entry:
n n+1 ... n n+1 ...
+-----+-----+-----+-----+-----+-----+-----+-----+ +-----+-----+-----+-----+-----+-----+-----+-----+
| SYM | VAL | SYM | VAL | CLO | | | | | LL | VAL | VAL | CLO | | | | |
+-----+-----+-----+-----+-----+-----+-----+-----+ +-----+-----+-----+-----+-----+-----+-----+-----+
^ ^ ^ ^ ^
| | | | |
penv envend SP (who knows where) penv SP (who knows where)
sym is an argument name and val is its binding. CLO is a closed-up where LL is the lambda list, CLO is a closed-up environment vector
environment vector (which can be empty, i.e. NIL). (which can be empty, i.e. NIL). An environment vector is just a copy
CLO is always there, but there might be zero SYM/VAL pairs. of the stack from LL through CLO.
There might be zero values, in which case LL is NIL.
if tail==1, you are allowed (indeed encouraged) to overwrite this if tail==1, you are allowed (indeed encouraged) to overwrite this
environment, otherwise you have to put any new environment on the top environment, otherwise you have to put any new environment on the top
of the stack. of the stack.
*/ */
static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend) static value_t eval_sexpr(value_t e, value_t *penv, int tail)
{ {
value_t f, v, asym, *pv, *argsyms, *body, *lenv, *argenv; value_t f, v, *pv, *argsyms, *body, *lenv;
cons_t *c; cons_t *c;
symbol_t *sym; symbol_t *sym;
u_int32_t saveSP; u_int32_t saveSP, envsz;
int i, nargs, noeval=0; int i, nargs, noeval=0;
fixnum_t s; fixnum_t s;
cvalue_t *cv; cvalue_t *cv;
@ -669,15 +670,18 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
sym = (symbol_t*)ptr(e); sym = (symbol_t*)ptr(e);
if (sym->syntax == TAG_CONST) return sym->binding; if (sym->syntax == TAG_CONST) return sym->binding;
while (1) { while (1) {
if (tag(*penv) == TAG_BUILTIN) v = *penv++;
penv = &vector_elt(*penv, 0); while (iscons(v)) {
if (*penv == e) if (car_(v)==e) return *penv;
return penv[1]; v = cdr_(v); penv++;
else if (*penv == NIL) }
if (v == e) return *penv; // dotted list
if (v != NIL) penv++;
if (*penv == NIL)
break; break;
penv+=2; penv = &vector_elt(*penv, 0);
} }
if ((v = sym->binding) == UNBOUND) // 3. global env if ((v = sym->binding) == UNBOUND)
raise(list2(UnboundError, e)); raise(list2(UnboundError, e));
return v; return v;
} }
@ -696,7 +700,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
else else
noeval = 2; noeval = 2;
} }
else f = eval_sexpr(v, penv, 0, envend); else f = eval(v);
v = Stack[saveSP]; v = Stack[saveSP];
if (tag(f) == TAG_BUILTIN) { if (tag(f) == TAG_BUILTIN) {
// handle builtin function // handle builtin function
@ -718,25 +722,30 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
break; break;
case F_LAMBDA: case F_LAMBDA:
// build a closure (lambda args body . env) // build a closure (lambda args body . env)
if (issymbol(*penv) && *penv != NIL) { if (*penv != NIL) {
// save temporary environment to the heap // save temporary environment to the heap
// find out how much space we need
nargs = ((int)(&Stack[envend] - penv - 1));
lenv = penv; lenv = penv;
pv = alloc_words(nargs + 2); //envsz = saveSP - (penv - &Stack[0]);
envsz = 2;
v = *penv;
while (iscons(v)) {
envsz++;
v = cdr_(v);
}
if (v != NIL) envsz++;
pv = alloc_words(envsz + 1);
PUSH(tagptr(pv, TAG_BUILTIN)); PUSH(tagptr(pv, TAG_BUILTIN));
pv[0] = (nargs+1)<<2; pv[0] = envsz<<2;
pv++; pv++;
while (nargs--) while (envsz--)
*pv++ = *penv++; *pv++ = *penv++;
// final element points to existing cloenv
*pv = Stack[envend-1];
// environment representation changed; install // environment representation changed; install
// the new representation so everybody can see it // the new representation so everybody can see it
*lenv = Stack[SP-1]; lenv[0] = NIL;
lenv[1] = Stack[SP-1];
} }
else { else {
PUSH(*penv); // env has already been captured; share PUSH(penv[1]); // env has already been captured; share
} }
c = (cons_t*)ptr(v=cons_reserve(3)); c = (cons_t*)ptr(v=cons_reserve(3));
c->car = LAMBDA; c->car = LAMBDA;
@ -746,22 +755,6 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
c->car = car(cdr_(Stack[saveSP])); //body c->car = car(cdr_(Stack[saveSP])); //body
c->cdr = Stack[SP-1]; //env c->cdr = Stack[SP-1]; //env
break; break;
case F_LABEL:
// the syntax of label is (label name (lambda args body))
// nothing else is guaranteed to work
PUSH(car(Stack[saveSP]));
PUSH(car(cdr_(Stack[saveSP])));
body = &Stack[SP-1];
*body = eval(*body); // evaluate lambda
pv = alloc_words(4);
pv[0] = 3<<2; // vector size 3
// add [name fn] to front of function's environment
pv[1] = Stack[SP-2]; // name
pv[2] = v = *body; // lambda
f = cdr(cdr(v));
pv[3] = cdr(f);
cdr_(f) = tagptr(pv, TAG_BUILTIN);
break;
case F_IF: case F_IF:
v = car(Stack[saveSP]); v = car(Stack[saveSP]);
if (eval(v) != NIL) if (eval(v) != NIL)
@ -843,7 +836,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
} }
break; break;
case F_TRYCATCH: case F_TRYCATCH:
v = do_trycatch(car(Stack[saveSP]), penv, envend); v = do_trycatch(car(Stack[saveSP]), penv);
break; break;
// ordinary functions // ordinary functions
@ -851,15 +844,24 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
argcount("set", nargs, 2); argcount("set", nargs, 2);
e = Stack[SP-2]; e = Stack[SP-2];
while (1) { while (1) {
if (tag(*penv) == TAG_BUILTIN) v = *penv++;
penv = &vector_elt(*penv, 0); while (iscons(v)) {
if (*penv == e) { if (car_(v)==e) {
penv[1] = Stack[SP-1]; *penv = Stack[SP-1];
SP=saveSP; return penv[1]; SP=saveSP;
return *penv;
}
v = cdr_(v); penv++;
} }
else if (*penv == NIL) if (v == e) {
*penv = Stack[SP-1];
SP=saveSP;
return *penv;
}
if (v != NIL) penv++;
if (*penv == NIL)
break; break;
penv+=2; penv = &vector_elt(*penv, 0);
} }
sym = tosymbol(e, "set"); sym = tosymbol(e, "set");
v = Stack[SP-1]; v = Stack[SP-1];
@ -1132,13 +1134,17 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
v = Stack[SP-1]; v = Stack[SP-1];
if (tag(v)<0x2) { SP=saveSP; return v; } if (tag(v)<0x2) { SP=saveSP; return v; }
if (tail) { if (tail) {
*penv = NIL; penv[0] = NIL;
envend = SP = (u_int32_t)(penv-&Stack[0]) + 1; penv[1] = NIL;
e=v; goto eval_top; //envsz = 0;
SP = (u_int32_t)(penv-&Stack[0]) + 2;
e=v;
goto eval_top;
} }
else { else {
PUSH(NIL); PUSH(NIL);
v = eval_sexpr(v, &Stack[SP-1], 1, SP); PUSH(NIL);
v = eval_sexpr(v, &Stack[SP-2], 1);
} }
break; break;
case F_RAISE: case F_RAISE:
@ -1184,70 +1190,80 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
} }
apply_lambda: apply_lambda:
if (iscons(f)) { if (iscons(f)) {
// apply lambda or macro expression // apply lambda expression
PUSH(cdr(cdr_(f))); f = cdr_(f);
PUSH(car_(cdr_(f))); PUSH(f);
PUSH(car(f)); // arglist
argsyms = &Stack[SP-1]; argsyms = &Stack[SP-1];
argenv = &Stack[SP]; // argument environment starts now
// build a calling environment for the lambda // build a calling environment for the lambda
// the environment is the argument binds on top of the captured // the environment is the argument binds on top of the captured
// environment // environment
while (iscons(v)) { if (noeval) {
// bind args while (iscons(v)) {
if (!iscons(*argsyms)) { // bind args
if (*argsyms == NIL) if (!iscons(*argsyms)) {
lerror(ArgError, "apply: too many arguments"); if (*argsyms == NIL)
break; lerror(ArgError, "apply: too many arguments");
break;
}
PUSH(car_(v));
*argsyms = cdr_(*argsyms);
v = cdr_(v);
} }
asym = car_(*argsyms); if (*argsyms != NIL && issymbol(*argsyms))
if (asym==NIL || !issymbol(asym)) PUSH(v);
lerror(ArgError, "apply: invalid formal argument");
v = car_(v);
if (!noeval) {
v = eval(v);
}
PUSH(asym);
PUSH(v);
*argsyms = cdr_(*argsyms);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
} }
if (*argsyms != NIL) { else {
if (issymbol(*argsyms)) { while (iscons(v)) {
PUSH(*argsyms); // bind args
PUSH(Stack[saveSP]); if (!iscons(*argsyms)) {
if (!noeval) { if (*argsyms == NIL)
// this version uses collective allocation. about 7-10% lerror(ArgError, "apply: too many arguments");
// faster for lists with > 2 elements, but uses more break;
// stack space }
i = SP; v = eval(car_(v));
while (iscons(Stack[saveSP])) { PUSH(v);
PUSH(eval(car_(Stack[saveSP]))); *argsyms = cdr_(*argsyms);
Stack[saveSP] = cdr_(Stack[saveSP]); v = Stack[saveSP] = cdr_(Stack[saveSP]);
} }
nargs = SP-i; if (*argsyms != NIL && issymbol(*argsyms)) {
if (nargs) { PUSH(NIL);
Stack[i-1] = cons_reserve(nargs); // this version uses collective allocation. about 7-10%
c = (cons_t*)ptr(Stack[i-1]); // faster for lists with > 2 elements, but uses more
for(; i < (int)SP; i++) { // stack space
c->car = Stack[i]; i = SP;
c->cdr = tagptr(c+1, TAG_CONS); while (iscons(Stack[saveSP])) {
c++; v = car_(Stack[saveSP]);
} v = eval(v);
(c-1)->cdr = Stack[saveSP]; PUSH(v);
POPN(nargs); Stack[saveSP] = cdr_(Stack[saveSP]);
}
nargs = SP-i;
if (nargs) {
Stack[i-1] = cons_reserve(nargs);
c = (cons_t*)ptr(Stack[i-1]);
for(; i < (int)SP; i++) {
c->car = Stack[i];
c->cdr = tagptr(c+1, TAG_CONS);
c++;
} }
(c-1)->cdr = Stack[saveSP];
POPN(nargs);
} }
} }
else if (iscons(*argsyms)) {
lerror(ArgError, "apply: too few arguments");
}
} }
PUSH(cdr(Stack[saveSP+1])); // add cloenv to new environment if (iscons(*argsyms)) {
e = car_(Stack[saveSP+1]); lerror(ArgError, "apply: too few arguments");
}
*argsyms = car_(Stack[saveSP+1]);
f = cdr_(Stack[saveSP+1]);
PUSH(cdr(f));
e = car_(f);
// macro: evaluate expansion in the calling environment // macro: evaluate expansion in the calling environment
if (noeval == 2) { if (noeval == 2) {
if (tag(e)<0x2) ; if (tag(e)<0x2) ;
else e = eval_sexpr(e, argenv, 1, SP); else e = eval_sexpr(e, argsyms, 1);
SP = saveSP; SP = saveSP;
if (tag(e)<0x2) return(e); if (tag(e)<0x2) return(e);
noeval = 0; noeval = 0;
@ -1258,14 +1274,15 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, u_int32_t envend)
if (tail) { if (tail) {
noeval = 0; noeval = 0;
// ok to overwrite environment // ok to overwrite environment
nargs = (int)(&Stack[SP] - argenv); s = SP - saveSP - 2;
for(i=0; i < nargs; i++) for(i=0; i < s; i++)
penv[i] = argenv[i]; penv[i] = argsyms[i];
envend = SP = (u_int32_t)((penv+nargs) - &Stack[0]); SP = (u_int32_t)((penv+s) - &Stack[0]);
//envsz = s;
goto eval_top; goto eval_top;
} }
else { else {
v = eval_sexpr(e, argenv, 1, SP); v = eval_sexpr(e, argsyms, 1);
SP = saveSP; SP = saveSP;
return v; return v;
} }
@ -1296,7 +1313,6 @@ void lisp_init(void)
NIL = symbol("nil"); setc(NIL, NIL); NIL = symbol("nil"); setc(NIL, NIL);
T = symbol("T"); setc(T, T); T = symbol("T"); setc(T, T);
LAMBDA = symbol("lambda"); LAMBDA = symbol("lambda");
LABEL = symbol("label");
QUOTE = symbol("quote"); QUOTE = symbol("quote");
VECTOR = symbol("vector"); VECTOR = symbol("vector");
TRYCATCH = symbol("trycatch"); TRYCATCH = symbol("trycatch");
@ -1351,7 +1367,8 @@ value_t toplevel_eval(value_t expr)
value_t v; value_t v;
u_int32_t saveSP = SP; u_int32_t saveSP = SP;
PUSH(NIL); PUSH(NIL);
v = topeval(expr, &Stack[SP-1]); PUSH(NIL);
v = topeval(expr, &Stack[SP-2]);
SP = saveSP; SP = saveSP;
return v; return v;
} }

2
femtolisp/flisp.h
View File

@ -77,7 +77,7 @@ extern u_int32_t SP;
enum { enum {
// special forms // special forms
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, F_LABEL, F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
F_TRYCATCH, F_PROGN, F_TRYCATCH, F_PROGN,
// functions // functions
F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP, F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP,

4
femtolisp/perf.lsp
View File

@ -15,3 +15,7 @@
(princ "mexpand: ") (princ "mexpand: ")
(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2)))) (time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
(path.cwd "ast")
(princ "p-lambda: ")
(load "rpasses.lsp")
(path.cwd "..")

3
femtolisp/system.lsp
View File

@ -20,6 +20,9 @@
(list 'set-syntax (list 'quote name) (list 'set-syntax (list 'quote name)
(list 'lambda args (f-body body))))) (list 'lambda args (f-body body)))))
(defmacro label (name fn)
(list (list 'lambda (cons name nil) (list 'setq name fn)) nil))
; support both CL defun and Scheme-style define ; support both CL defun and Scheme-style define
(defmacro defun (name args . body) (defmacro defun (name args . body)
(list 'setq name (list 'lambda args (f-body body)))) (list 'setq name (list 'lambda args (f-body body))))