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

simplifying code by eliminating the hybrid stack/heap calling convention 

other misc. cleanup
This commit is contained in:
JeffBezanson 2009-07-20 04:57:17 +00:00
parent 642d1e1bd4
commit 57c066fcdf
12 changed files with 106 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
femtolisp/bootstrap.sh
View File

@ -3,7 +3,7 @@
cp flisp.boot flisp.boot.bak cp flisp.boot flisp.boot.bak
echo "Creating stage 0 boot file..." echo "Creating stage 0 boot file..."
#../../branches/interpreter/femtolisp/flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot #../../branches/interpreter/femtolisp/flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new
./flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new ./flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new
mv flisp.boot.new flisp.boot mv flisp.boot.new flisp.boot

7
femtolisp/builtins.c
View File

@ -35,15 +35,8 @@ static value_t fl_nconc(value_t *args, u_int32_t nargs)
cons_t *c; cons_t *c;
uint32_t i=0; uint32_t i=0;
while (1) { while (1) {
if (i >= MAX_ARGS) {
lst = car_(args[MAX_ARGS]);
args[MAX_ARGS] = cdr_(args[MAX_ARGS]);
if (!iscons(args[MAX_ARGS])) break;
}
else {
lst = args[i++]; lst = args[i++];
if (i >= nargs) break; if (i >= nargs) break;
}
if (iscons(lst)) { if (iscons(lst)) {
*pcdr = lst; *pcdr = lst;
c = (cons_t*)ptr(lst); c = (cons_t*)ptr(lst);

81
femtolisp/compiler.lsp
View File

@ -209,6 +209,8 @@
; number of non-nulls ; number of non-nulls
(define (nnn e) (count (lambda (x) (not (null? x))) e)) (define (nnn e) (count (lambda (x) (not (null? x))) e))
(define (printable? x) (not (iostream? x)))
(define (compile-sym g env s Is) (define (compile-sym g env s Is)
(let ((loc (lookup-sym s env 0 #t))) (let ((loc (lookup-sym s env 0 #t)))
(case (car loc) (case (car loc)
@ -216,7 +218,11 @@
(closed (emit g (aref Is 1) (cadr loc) (caddr loc)) (closed (emit g (aref Is 1) (cadr loc) (caddr loc))
; update index of most distant captured frame ; update index of most distant captured frame
(bcode:cdepth g (- (nnn (cdr env)) 1 (cadr loc)))) (bcode:cdepth g (- (nnn (cdr env)) 1 (cadr loc))))
(else (emit g (aref Is 2) s))))) (else
(if (and (constant? s)
(printable? (top-level-value s)))
(emit g :loadv (top-level-value s))
(emit g (aref Is 2) s))))))
(define (compile-if g env tail? x) (define (compile-if g env tail? x)
(let ((elsel (make-label g)) (let ((elsel (make-label g))
@ -300,8 +306,6 @@
(define (compile-or g env tail? forms) (define (compile-or g env tail? forms)
(compile-short-circuit g env tail? forms #f :brt)) (compile-short-circuit g env tail? forms #f :brt))
(define MAX_ARGS 127)
(define (list-partition l n) (define (list-partition l n)
(define (list-part- l n i subl acc) (define (list-part- l n i subl acc)
(cond ((atom? l) (if (> i 0) (cond ((atom? l) (if (> i 0)
@ -313,23 +317,16 @@
(error "list-partition: invalid count") (error "list-partition: invalid count")
(reverse! (list-part- l n 0 () ())))) (reverse! (list-part- l n 0 () ()))))
(define (just-compile-args g lst env) (define (make-nested-arglist args n)
(for-each (lambda (a)
(compile-in g env #f a))
lst))
(define (compile-arglist g env lst)
(let ((argtail (length> lst MAX_ARGS)))
(if argtail
(begin (just-compile-args g (list-head lst MAX_ARGS) env)
(let ((rest
(cons nconc (cons nconc
(map (lambda (l) (cons list l)) (map (lambda (l) (cons list l))
(list-partition argtail MAX_ARGS))))) (list-partition args n))))
(compile-in g env #f rest))
(+ MAX_ARGS 1)) (define (compile-arglist g env lst)
(begin (just-compile-args g lst env) (for-each (lambda (a)
(length lst))))) (compile-in g env #f a))
lst)
(length lst))
(define (argc-error head count) (define (argc-error head count)
(error (string "compile error: " head " expects " count (error (string "compile error: " head " expects " count
@ -342,7 +339,7 @@
(if (and (pair? head) (if (and (pair? head)
(eq? (car head) 'lambda) (eq? (car head) 'lambda)
(list? (cadr head)) (list? (cadr head))
(not (length> (cadr head) MAX_ARGS))) (not (length> (cadr head) 255)))
(compile-let g env tail? x) (compile-let g env tail? x)
(compile-call g env tail? x)))) (compile-call g env tail? x))))
@ -375,22 +372,7 @@
(lambda (b) (lambda (b)
(get b2i b #f)))) (get b2i b #f))))
(define (compile-call g env tail? x) (define (compile-builtin-call g env tail? x head b nargs)
(let ((head (car x)))
(let ((head
(if (and (symbol? head)
(not (in-env? head env))
(bound? head)
(constant? head)
(builtin? (top-level-value head)))
(top-level-value head)
head)))
(let ((b (and (builtin? head)
(builtin->instruction head))))
(if (not b)
(compile-in g env #f head))
(let ((nargs (compile-arglist g env (cdr x))))
(if b
(let ((count (get arg-counts b #f))) (let ((count (get arg-counts b #f)))
(if (and count (if (and count
(not (length= (cdr x) count))) (not (length= (cdr x) count)))
@ -415,8 +397,31 @@
(:apply (if (< nargs 2) (:apply (if (< nargs 2)
(argc-error head 2) (argc-error head 2)
(emit g (if tail? :tapply :apply) nargs))) (emit g (if tail? :tapply :apply) nargs)))
(else (emit g b)))) (else (emit g b)))))
(emit g (if tail? :tcall :call) nargs)))))))
(define (compile-call g env tail? x)
(let ((head (car x)))
(let ((head
(if (and (symbol? head)
(not (in-env? head env))
(bound? head)
(constant? head)
(builtin? (top-level-value head)))
(top-level-value head)
head)))
(if (length> (cdr x) 255)
; argument count is a uint8, so for more than 255 arguments
; we use apply on a list built from sublists that fit the limit
(compile-in g env tail?
`(#.apply ,head ,(make-nested-arglist (cdr x) 255)))
(let ((b (and (builtin? head)
(builtin->instruction head))))
(if (not b)
(compile-in g env #f head))
(let ((nargs (compile-arglist g env (cdr x))))
(if b
(compile-builtin-call g env tail? x head b nargs)
(emit g (if tail? :tcall :call) nargs))))))))
(define (expand-define form body) (define (expand-define form body)
(if (symbol? form) (if (symbol? form)
@ -514,7 +519,7 @@
'lambda 'lambda
(lastcdr f)))) (lastcdr f))))
(cond ((not (null? let?)) (emit g :let)) (cond ((not (null? let?)) (emit g :let))
((length> args MAX_ARGS) (emit g (if (null? (lastcdr args)) ((length> args 255) (emit g (if (null? (lastcdr args))
:largc :lvargc) :largc :lvargc)
(length args))) (length args)))
((null? (lastcdr args)) (emit g :argc (length args))) ((null? (lastcdr args)) (emit g :argc (length args)))

2
femtolisp/cvalues.c
View File

@ -464,8 +464,6 @@ value_t cvalue_array(value_t *args, u_int32_t nargs)
argcount("array", nargs, 1); argcount("array", nargs, 1);
cnt = nargs - 1; cnt = nargs - 1;
if (nargs > MAX_ARGS)
cnt += (llength(args[MAX_ARGS])-1);
fltype_t *type = get_array_type(args[0]); fltype_t *type = get_array_type(args[0]);
elsize = type->elsz; elsize = type->elsz;
sz = elsize * cnt; sz = elsize * cnt;

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

125
femtolisp/flisp.c
View File

@ -578,12 +578,21 @@ void gc(int mustgrow)
gc(0); gc(0);
} }
static void grow_stack()
{
size_t newsz = N_STACK + (N_STACK>>1);
value_t *ns = realloc(Stack, newsz*sizeof(value_t));
if (ns == NULL)
lerror(MemoryError, "stack overflow");
Stack = ns;
N_STACK = newsz;
}
// utils ---------------------------------------------------------------------- // utils ----------------------------------------------------------------------
// apply function with n args on the stack // apply function with n args on the stack
static value_t _applyn(uint32_t n) static value_t _applyn(uint32_t n)
{ {
assert(n <= MAX_ARGS+1);
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;
@ -607,10 +616,8 @@ value_t apply(value_t f, value_t l)
PUSH(f); PUSH(f);
while (iscons(v)) { while (iscons(v)) {
if ((SP-n-1) == MAX_ARGS) { if (SP >= N_STACK)
PUSH(v); grow_stack();
break;
}
PUSH(car_(v)); PUSH(car_(v));
v = cdr_(v); v = cdr_(v);
} }
@ -622,12 +629,13 @@ value_t apply(value_t f, value_t l)
value_t applyn(uint32_t n, value_t f, ...) value_t applyn(uint32_t n, value_t f, ...)
{ {
assert(n <= MAX_ARGS);
va_list ap; va_list ap;
va_start(ap, f); va_start(ap, f);
size_t i; size_t i;
PUSH(f); PUSH(f);
while (SP+n > N_STACK)
grow_stack();
for(i=0; i < n; i++) { for(i=0; i < n; i++) {
value_t a = va_arg(ap, value_t); value_t a = va_arg(ap, value_t);
PUSH(a); PUSH(a);
@ -644,6 +652,8 @@ value_t listn(size_t n, ...)
uint32_t si = SP; uint32_t si = SP;
size_t i; size_t i;
while (SP+n > N_STACK)
grow_stack();
for(i=0; i < n; i++) { for(i=0; i < n; i++) {
value_t a = va_arg(ap, value_t); value_t a = va_arg(ap, value_t);
PUSH(a); PUSH(a);
@ -715,7 +725,7 @@ static value_t _list(value_t *args, uint32_t nargs, int star)
c->cdr = tagptr(c+1, TAG_CONS); c->cdr = tagptr(c+1, TAG_CONS);
c++; c++;
} }
if (star || nargs > MAX_ARGS) if (star)
(c-2)->cdr = (c-1)->car; (c-2)->cdr = (c-1)->car;
else else
(c-1)->cdr = NIL; (c-1)->cdr = NIL;
@ -805,18 +815,8 @@ static value_t do_trycatch()
#define DISPATCH goto dispatch #define DISPATCH goto dispatch
#endif #endif
static void grow_stack()
{
size_t newsz = N_STACK + (N_STACK>>1);
value_t *ns = realloc(Stack, newsz*sizeof(value_t));
if (ns == NULL)
lerror(MemoryError, "stack overflow");
Stack = ns;
N_STACK = newsz;
}
/* /*
stack on entry: <func> <up to MAX_ARGS args...> <arglist if nargs>MAX_ARGS> stack on entry: <func> <nargs args...>
caller's responsibility: caller's responsibility:
- put the stack in this state - put the stack in this state
- provide arg count - provide arg count
@ -886,18 +886,10 @@ static value_t apply_cl(uint32_t nargs)
NEXT_OP; NEXT_OP;
OP(OP_VARGC) OP(OP_VARGC)
i = *ip++; i = *ip++;
do_vargc:
s = (fixnum_t)nargs - (fixnum_t)i; s = (fixnum_t)nargs - (fixnum_t)i;
if (s > 0) { if (s > 0) {
v = list(&Stack[bp+i], s); v = list(&Stack[bp+i], s);
if (nargs > MAX_ARGS) {
if (s == 1) {
v = car_(v);
}
else {
c = (cons_t*)curheap;
(c-2)->cdr = (c-1)->car;
}
}
Stack[bp+i] = v; Stack[bp+i] = v;
if (s > 1) { if (s > 1) {
Stack[bp+i+1] = Stack[bp+nargs+0]; Stack[bp+i+1] = Stack[bp+nargs+0];
@ -923,39 +915,17 @@ static value_t apply_cl(uint32_t nargs)
nargs = i+1; nargs = i+1;
NEXT_OP; NEXT_OP;
OP(OP_LARGC) OP(OP_LARGC)
OP(OP_LVARGC) n = GET_INT32(ip); ip+=4;
// move extra arguments from list to stack if (nargs != n) {
i = GET_INT32(ip); ip+=4; if (nargs > n)
e = Stack[curr_frame-5]; // cloenv
n = Stack[curr_frame-4]; // prev curr_frame
POPN(5);
if (nargs > MAX_ARGS) {
v = POP(); // list of rest args
nargs--;
}
else v = NIL;
while (nargs < i) {
if (!iscons(v))
lerror(ArgError, "apply: too few arguments");
PUSH(car_(v));
nargs++;
v = cdr_(v);
}
if (ip[-5] == OP_LVARGC) {
PUSH(v);
nargs++;
}
else {
if (iscons(v))
lerror(ArgError, "apply: too many arguments"); lerror(ArgError, "apply: too many arguments");
else
lerror(ArgError, "apply: too few arguments");
} }
PUSH(e);
PUSH(n);
PUSH(nargs);
SP++;//PUSH(0);
PUSH(0);
curr_frame = SP;
NEXT_OP; NEXT_OP;
OP(OP_LVARGC)
i = GET_INT32(ip); ip+=4;
goto do_vargc;
OP(OP_LET) OP(OP_LET)
// last arg is closure environment to use // last arg is closure environment to use
nargs--; nargs--;
@ -1166,15 +1136,10 @@ static value_t apply_cl(uint32_t nargs)
n = *ip++; n = *ip++;
apply_apply: apply_apply:
v = POP(); // arglist v = POP(); // arglist
if (n > MAX_ARGS) {
v = apply_liststar(v, 1);
}
n = SP-(n-2); // n-2 == # leading arguments not in the list n = SP-(n-2); // n-2 == # leading arguments not in the list
while (iscons(v)) { while (iscons(v)) {
if (SP-n == MAX_ARGS) { if (SP >= N_STACK)
PUSH(v); grow_stack();
break;
}
PUSH(car_(v)); PUSH(car_(v));
v = cdr_(v); v = cdr_(v);
} }
@ -1187,7 +1152,6 @@ static value_t apply_cl(uint32_t nargs)
apply_add: apply_add:
s = 0; s = 0;
i = SP-n; i = SP-n;
if (n > MAX_ARGS) goto add_ovf;
for (; i < SP; i++) { for (; i < SP; i++) {
if (isfixnum(Stack[i])) { if (isfixnum(Stack[i])) {
s += numval(Stack[i]); s += numval(Stack[i]);
@ -1265,13 +1229,11 @@ static value_t apply_cl(uint32_t nargs)
apply_mul: apply_mul:
accum = 1; accum = 1;
i = SP-n; i = SP-n;
if (n > MAX_ARGS) goto mul_ovf;
for (; i < SP; i++) { for (; i < SP; i++) {
if (isfixnum(Stack[i])) { if (isfixnum(Stack[i])) {
accum *= numval(Stack[i]); accum *= numval(Stack[i]);
} }
else { else {
mul_ovf:
v = fl_mul_any(&Stack[i], SP-i, accum); v = fl_mul_any(&Stack[i], SP-i, accum);
break; break;
} }
@ -1343,23 +1305,10 @@ static value_t apply_cl(uint32_t nargs)
OP(OP_VECTOR) OP(OP_VECTOR)
n = *ip++; n = *ip++;
apply_vector: apply_vector:
if (n > MAX_ARGS) { v = alloc_vector(n, 0);
i = llength(Stack[SP-1])-1;
}
else i = 0;
v = alloc_vector(n+i, 0);
if (n) { if (n) {
memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t)); memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t));
e = POP(); POPN(n);
POPN(n-1);
}
if (n > MAX_ARGS) {
i = n-1;
while (iscons(e)) {
vector_elt(v,i) = car_(e);
i++;
e = cdr_(e);
}
} }
PUSH(v); PUSH(v);
NEXT_OP; NEXT_OP;
@ -1684,7 +1633,6 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
break; break;
case OP_TAPPLY: case OP_APPLY: case OP_TAPPLY: case OP_APPLY:
if (sp+MAX_ARGS+1 > maxsp) maxsp = sp+MAX_ARGS+1;
n = *ip++; n = *ip++;
sp -= (n-1); sp -= (n-1);
break; break;
@ -1860,15 +1808,8 @@ value_t fl_append(value_t *args, u_int32_t nargs)
fl_gc_handle(&lastcons); fl_gc_handle(&lastcons);
uint32_t i=0; uint32_t i=0;
while (1) { while (1) {
if (i >= MAX_ARGS) {
lst = car_(args[MAX_ARGS]);
args[MAX_ARGS] = cdr_(args[MAX_ARGS]);
if (!iscons(args[MAX_ARGS])) break;
}
else {
lst = args[i++]; lst = args[i++];
if (i >= nargs) break; if (i >= nargs) break;
}
if (iscons(lst)) { if (iscons(lst)) {
lst = FL_COPYLIST(lst); lst = FL_COPYLIST(lst);
if (first == NIL) if (first == NIL)
@ -1893,10 +1834,6 @@ value_t fl_liststar(value_t *args, u_int32_t nargs)
{ {
if (nargs == 1) return args[0]; if (nargs == 1) return args[0];
else if (nargs == 0) argcount("list*", nargs, 1); else if (nargs == 0) argcount("list*", nargs, 1);
if (nargs > MAX_ARGS) {
args[MAX_ARGS] = apply_liststar(args[MAX_ARGS], 1);
return list(args, nargs);
}
return _list(args, nargs, 1); return _list(args, nargs, 1);
} }

11
femtolisp/flisp.h
View File

@ -102,22 +102,13 @@ typedef struct _symbol_t {
void fl_gc_handle(value_t *pv); void fl_gc_handle(value_t *pv);
void fl_free_gc_handles(int n); void fl_free_gc_handles(int n);
// maximum number of explicit arguments. the 128th arg is a list of rest args.
// the largest value nargs can have is MAX_ARGS+1
#define MAX_ARGS 127
#include "opcodes.h" #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
// modifies args[MAX_ARGS] when nargs==MAX_ARGS+1
#define FOR_ARGS(i, i0, arg, args) \ #define FOR_ARGS(i, i0, arg, args) \
for(i=i0; (((size_t)i<nargs || \ for(i=i0; ((size_t)i)<nargs && ((arg=args[i]) || 1); i++)
(i>MAX_ARGS && iscons(args[MAX_ARGS]))) && \
((i>=MAX_ARGS?(arg=car_(args[MAX_ARGS]), \
args[MAX_ARGS]=cdr_(args[MAX_ARGS])) : \
(arg = args[i])) || 1)); i++)
#define N_BUILTINS ((int)N_OPCODES) #define N_BUILTINS ((int)N_OPCODES)

2
femtolisp/iostream.c
View File

@ -171,7 +171,7 @@ value_t fl_ioseek(value_t *args, u_int32_t nargs)
static void do_ioprint(value_t *args, u_int32_t nargs, char *fname) static void do_ioprint(value_t *args, u_int32_t nargs, char *fname)
{ {
if (nargs < 2 || nargs > MAX_ARGS) if (nargs < 2)
argcount(fname, nargs, 2); argcount(fname, nargs, 2);
ios_t *s = toiostream(args[0], fname); ios_t *s = toiostream(args[0], fname);
unsigned i; unsigned i;

11
femtolisp/system.lsp
View File

@ -309,6 +309,11 @@
(or (and (pair? x) (or (eq (car x) '*comma-at*) (or (and (pair? x) (or (eq (car x) '*comma-at*)
(eq (car x) '*comma-dot*))) (eq (car x) '*comma-dot*)))
(eq x '*comma*))) (eq x '*comma*)))
; bracket without splicing
(define (bq-bracket1 x)
(if (and (pair? x) (eq (car x) '*comma*))
(cadr x)
(bq-process x)))
(cond ((self-evaluating? x) (cond ((self-evaluating? x)
(if (vector? x) (if (vector? x)
(let ((body (bq-process (vector->list x)))) (let ((body (bq-process (vector->list x))))
@ -345,12 +350,6 @@
((eq (car x) '*comma-dot*) (cadr x)) ((eq (car x) '*comma-dot*) (cadr x))
(#t (list list (bq-process x))))) (#t (list list (bq-process x)))))
; bracket without splicing
(define (bq-bracket1 x)
(if (and (pair? x) (eq (car x) '*comma*))
(cadr x)
(bq-process x)))
; standard macros ------------------------------------------------------------- ; standard macros -------------------------------------------------------------
(define (quote-value v) (define (quote-value v)

2
femtolisp/table.c
View File

@ -84,8 +84,6 @@ static htable_t *totable(value_t v, char *fname)
value_t fl_table(value_t *args, uint32_t nargs) value_t fl_table(value_t *args, uint32_t nargs)
{ {
size_t cnt = (size_t)nargs; size_t cnt = (size_t)nargs;
if (nargs > MAX_ARGS)
cnt += (llength(args[MAX_ARGS])-1);
if (cnt & 1) if (cnt & 1)
lerror(ArgError, "table: arguments must come in pairs"); lerror(ArgError, "table: arguments must come in pairs");
value_t nt; value_t nt;

3
femtolisp/todo
View File

@ -1042,7 +1042,8 @@ new evaluator todo:
* stack traces and better debugging support * stack traces and better debugging support
- make maxstack calculation robust against invalid bytecode - make maxstack calculation robust against invalid bytecode
* improve internal define * improve internal define
- try removing MAX_ARGS trickery * try removing MAX_ARGS trickery
- apply optimization, avoid redundant list copying calling vararg fns
- let eversion - let eversion
* lambda lifting * lambda lifting
* let optimization * let optimization

2
femtolisp/unittest.lsp
View File

@ -98,6 +98,8 @@
; long argument lists ; long argument lists
(assert (= (apply + (iota 100000)) 4999950000)) (assert (= (apply + (iota 100000)) 4999950000))
(define MAX_ARGS 255)
(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1)))) (define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1))))
(define f (compile `(lambda ,as ,(lastcdr as)))) (define f (compile `(lambda ,as ,(lastcdr as))))
(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `())) (assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))