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
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
mv flisp.boot.new flisp.boot

11
femtolisp/builtins.c
View File

@ -35,15 +35,8 @@ static value_t fl_nconc(value_t *args, u_int32_t nargs)
cons_t *c;
uint32_t i=0;
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++];
if (i >= nargs) break;
}
lst = args[i++];
if (i >= nargs) break;
if (iscons(lst)) {
*pcdr = lst;
c = (cons_t*)ptr(lst);

109
femtolisp/compiler.lsp
View File

@ -209,6 +209,8 @@
; number of non-nulls
(define (nnn e) (count (lambda (x) (not (null? x))) e))
(define (printable? x) (not (iostream? x)))
(define (compile-sym g env s Is)
(let ((loc (lookup-sym s env 0 #t)))
(case (car loc)
@ -216,7 +218,11 @@
(closed (emit g (aref Is 1) (cadr loc) (caddr loc))
; update index of most distant captured frame
(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)
(let ((elsel (make-label g))
@ -300,8 +306,6 @@
(define (compile-or g env tail? forms)
(compile-short-circuit g env tail? forms #f :brt))
(define MAX_ARGS 127)
(define (list-partition l n)
(define (list-part- l n i subl acc)
(cond ((atom? l) (if (> i 0)
@ -313,23 +317,16 @@
(error "list-partition: invalid count")
(reverse! (list-part- l n 0 () ()))))
(define (just-compile-args g lst env)
(for-each (lambda (a)
(compile-in g env #f a))
lst))
(define (make-nested-arglist args n)
(cons nconc
(map (lambda (l) (cons list l))
(list-partition args n))))
(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
(map (lambda (l) (cons list l))
(list-partition argtail MAX_ARGS)))))
(compile-in g env #f rest))
(+ MAX_ARGS 1))
(begin (just-compile-args g lst env)
(length lst)))))
(for-each (lambda (a)
(compile-in g env #f a))
lst)
(length lst))
(define (argc-error head count)
(error (string "compile error: " head " expects " count
@ -342,7 +339,7 @@
(if (and (pair? head)
(eq? (car head) 'lambda)
(list? (cadr head))
(not (length> (cadr head) MAX_ARGS)))
(not (length> (cadr head) 255)))
(compile-let g env tail? x)
(compile-call g env tail? x))))
@ -375,6 +372,33 @@
(lambda (b)
(get b2i b #f))))
(define (compile-builtin-call g env tail? x head b nargs)
(let ((count (get arg-counts b #f)))
(if (and count
(not (length= (cdr x) count)))
(argc-error head count))
(case b ; handle special cases of vararg builtins
(:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs)))
(:+ (cond ((= nargs 0) (emit g :load0))
((= nargs 2) (emit g :add2))
(else (emit g b nargs))))
(:- (cond ((= nargs 0) (argc-error head 1))
((= nargs 1) (emit g :neg))
((= nargs 2) (emit g :sub2))
(else (emit g b nargs))))
(:* (if (= nargs 0) (emit g :load1)
(emit g b nargs)))
(:/ (if (= nargs 0)
(argc-error head 1)
(emit g b nargs)))
(:vector (if (= nargs 0)
(emit g :loadv [])
(emit g b nargs)))
(:apply (if (< nargs 2)
(argc-error head 2)
(emit g (if tail? :tapply :apply) nargs)))
(else (emit g b)))))
(define (compile-call g env tail? x)
(let ((head (car x)))
(let ((head
@ -385,38 +409,19 @@
(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)))
(if (and count
(not (length= (cdr x) count)))
(argc-error head count))
(case b ; handle special cases of vararg builtins
(:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs)))
(:+ (cond ((= nargs 0) (emit g :load0))
((= nargs 2) (emit g :add2))
(else (emit g b nargs))))
(:- (cond ((= nargs 0) (argc-error head 1))
((= nargs 1) (emit g :neg))
((= nargs 2) (emit g :sub2))
(else (emit g b nargs))))
(:* (if (= nargs 0) (emit g :load1)
(emit g b nargs)))
(:/ (if (= nargs 0)
(argc-error head 1)
(emit g b nargs)))
(:vector (if (= nargs 0)
(emit g :loadv [])
(emit g b nargs)))
(:apply (if (< nargs 2)
(argc-error head 2)
(emit g (if tail? :tapply :apply) nargs)))
(else (emit g b))))
(emit g (if tail? :tcall :call) nargs)))))))
(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)
(if (symbol? form)
@ -514,7 +519,7 @@
'lambda
(lastcdr f))))
(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)
(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);
cnt = nargs - 1;
if (nargs > MAX_ARGS)
cnt += (llength(args[MAX_ARGS])-1);
fltype_t *type = get_array_type(args[0]);
elsize = type->elsz;
sz = elsize * cnt;

2
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

129
femtolisp/flisp.c
View File

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

13
femtolisp/flisp.h
View File

@ -102,22 +102,13 @@ typedef struct _symbol_t {
void fl_gc_handle(value_t *pv);
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"
// utility for iterating over all arguments in a builtin
// i=index, i0=start index, arg = var for each arg, args = arg array
// assumes "nargs" is the argument count
// modifies args[MAX_ARGS] when nargs==MAX_ARGS+1
#define FOR_ARGS(i, i0, arg, args) \
for(i=i0; (((size_t)i<nargs || \
(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 FOR_ARGS(i, i0, arg, args) \
for(i=i0; ((size_t)i)<nargs && ((arg=args[i]) || 1); i++)
#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)
{
if (nargs < 2 || nargs > MAX_ARGS)
if (nargs < 2)
argcount(fname, nargs, 2);
ios_t *s = toiostream(args[0], fname);
unsigned i;

11
femtolisp/system.lsp
View File

@ -309,6 +309,11 @@
(or (and (pair? x) (or (eq (car x) '*comma-at*)
(eq (car x) '*comma-dot*)))
(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)
(if (vector? x)
(let ((body (bq-process (vector->list x))))
@ -345,12 +350,6 @@
((eq (car x) '*comma-dot*) (cadr 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 -------------------------------------------------------------
(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)
{
size_t cnt = (size_t)nargs;
if (nargs > MAX_ARGS)
cnt += (llength(args[MAX_ARGS])-1);
if (cnt & 1)
lerror(ArgError, "table: arguments must come in pairs");
value_t nt;

3
femtolisp/todo
View File

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

2
femtolisp/unittest.lsp
View File

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