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

changing boot file format; the old one did not preserve sharing 

between top-level functions
making colon at the end also valid for keywords
adding keyword? predicate
fixing bug in map
adding functions to emulate values and call-with-values
adding receive macro
improving equal? on closures
adding lambda-lifting optimization to the compiler
This commit is contained in:
JeffBezanson 2009-07-17 01:30:26 +00:00
parent c19aaeabd6
commit 2c304edf42
8 changed files with 130 additions and 376 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
femtolisp/builtins.c
View File

@ -138,6 +138,14 @@ static value_t fl_symbol(value_t *args, u_int32_t nargs)
return symbol(cvalue_data(args[0]));
}
static value_t fl_keywordp(value_t *args, u_int32_t nargs)
{
argcount("keyword?", nargs, 1);
symbol_t *sym = tosymbol(args[0], "keyword?");
char *str = sym->name;
return fl_is_keyword_name(str, strlen(str)) ? FL_T : FL_F;
}
static value_t fl_top_level_value(value_t *args, u_int32_t nargs)
{
argcount("top-level-value", nargs, 1);
@ -417,6 +425,7 @@ static builtinspec_t builtin_info[] = {
{ "raise", fl_raise },
{ "exit", fl_exit },
{ "symbol", fl_symbol },
{ "keyword?", fl_keywordp },
{ "fixnum", fl_fixnum },
{ "truncate", fl_truncate },

31
femtolisp/compiler.lsp
View File

@ -46,10 +46,11 @@
:aref 2 :aset! 3
:div0 2))
(define (make-code-emitter) (vector () (table) 0))
(define (make-code-emitter) (vector () (table) 0 +inf.0))
(define (bcode:code b) (aref b 0))
(define (bcode:ctable b) (aref b 1))
(define (bcode:nconst b) (aref b 2))
(define (bcode:cdepth b d) (aset! b 3 (min (aref b 3) d)))
; get an index for a referenced value in a bytecode object
(define (bcode:indexfor b v)
(let ((const-to-idx (bcode:ctable b))
@ -205,11 +206,16 @@
(if (or arg? (null? curr)) lev (+ lev 1))
#f)))))
; number of non-nulls
(define (nnn e) (count (lambda (x) (not (null? x))) e))
(define (compile-sym g env s Is)
(let ((loc (lookup-sym s env 0 #t)))
(case (car loc)
(arg (emit g (aref Is 0) (cadr loc)))
(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
(bcode:cdepth g (- (nnn (cdr env)) 1 (cadr loc))))
(else (emit g (aref Is 2) s)))))
(define (compile-if g env tail? x)
@ -345,7 +351,9 @@
(args (cdr x)))
(unless (length= args (length (cadr head)))
(error (string "apply: incorrect number of arguments to " head)))
(emit g :loadv (compile-f env head #t))
(receive (the-f dept) (compile-f- env head #t)
(emit g :loadv the-f)
(bcode:cdepth g dept))
(let ((nargs (compile-arglist g env args)))
(emit g :copyenv)
(emit g (if tail? :tcall :call) (+ 1 nargs)))))
@ -428,8 +436,11 @@
(if (compile-if g env tail? x))
(begin (compile-begin g env tail? (cdr x)))
(prog1 (compile-prog1 g env x))
(lambda (begin (emit g :loadv (compile-f env x))
(emit g :closure)))
(lambda (receive (the-f dept) (compile-f- env x)
(begin (emit g :loadv the-f)
(bcode:cdepth g dept)
(if (< dept (nnn env))
(emit g :closure)))))
(and (compile-and g env tail? (cdr x)))
(or (compile-or g env tail? (cdr x)))
(while (compile-while g env (cadr x) (cons 'begin (cddr x))))
@ -446,6 +457,11 @@
(else (compile-app g env tail? x))))))
(define (compile-f env f . let?)
(receive (ff ignore)
(apply compile-f- env f let?)
ff))
(define (compile-f- env f . let?)
(let ((g (make-code-emitter))
(args (cadr f)))
(cond ((not (null? let?)) (emit g :let))
@ -456,8 +472,9 @@
(else (emit g :vargc (if (atom? args) 0 (length args)))))
(compile-in g (cons (to-proper args) env) #t (caddr f))
(emit g :ret)
(function (encode-byte-code (bcode:code g))
(const-to-idx-vec g) (lastcdr f))))
(values (function (encode-byte-code (bcode:code g))
(const-to-idx-vec g) (lastcdr f))
(aref g 3))))
(define (compile f) (compile-f () f))

49
femtolisp/equal.c
View File

@ -89,9 +89,18 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq)
}
break;
case TAG_FUNCTION:
if (uintval(a) > N_BUILTINS || uintval(b) > N_BUILTINS)
return fixnum(1);
if (tagb == TAG_FUNCTION) {
if (uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS) {
function_t *fa = (function_t*)ptr(a);
function_t *fb = (function_t*)ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq);
if (d==NIL || numval(d) != 0) return d;
d = bounded_compare(fa->vals, fb->vals, bound-1, eq);
if (d==NIL || numval(d) != 0) return d;
d = bounded_compare(fa->env, fb->env, bound-1, eq);
if (d==NIL || numval(d) != 0) return d;
return fixnum(0);
}
return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1);
}
break;
@ -122,12 +131,12 @@ static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
xb = vector_elt(b,i);
if (leafp(xa) || leafp(xb)) {
d = bounded_compare(xa, xb, 1, eq);
if (numval(d)!=0) return d;
if (d!=NIL && numval(d)!=0) return d;
}
else if (cmptag(xa) < cmptag(xb)) {
else if (tag(xa) < tag(xb)) {
return fixnum(-1);
}
else if (cmptag(xa) > cmptag(xb)) {
else if (tag(xa) > tag(xb)) {
return fixnum(1);
}
}
@ -142,7 +151,7 @@ static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
for (i = 0; i < m; i++) {
xa = vector_elt(a,i);
xb = vector_elt(b,i);
if (!leafp(xa) && !leafp(xb)) {
if (!leafp(xa) || tag(xa)==TAG_FUNCTION) {
d = cyc_compare(xa, xb, table, eq);
if (numval(d)!=0)
return d;
@ -156,6 +165,7 @@ static value_t cyc_vector_compare(value_t a, value_t b, htable_t *table,
static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
{
value_t d, ca, cb;
cyc_compare_top:
if (a==b)
return fixnum(0);
@ -163,12 +173,11 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
if (iscons(b)) {
value_t aa = car_(a); value_t da = cdr_(a);
value_t ab = car_(b); value_t db = cdr_(b);
int tagaa = cmptag(aa); int tagda = cmptag(da);
int tagab = cmptag(ab); int tagdb = cmptag(db);
value_t d, ca, cb;
int tagaa = tag(aa); int tagda = tag(da);
int tagab = tag(ab); int tagdb = tag(db);
if (leafp(aa) || leafp(ab)) {
d = bounded_compare(aa, ab, 1, eq);
if (numval(d)!=0) return d;
if (d!=NIL && numval(d)!=0) return d;
}
else if (tagaa < tagab)
return fixnum(-1);
@ -176,7 +185,7 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
return fixnum(1);
if (leafp(da) || leafp(db)) {
d = bounded_compare(da, db, 1, eq);
if (numval(d)!=0) return d;
if (d!=NIL && numval(d)!=0) return d;
}
else if (tagda < tagdb)
return fixnum(-1);
@ -202,6 +211,24 @@ static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
else if (isvector(a) && isvector(b)) {
return cyc_vector_compare(a, b, table, eq);
}
else if (isclosure(a) && isclosure(b)) {
function_t *fa = (function_t*)ptr(a);
function_t *fb = (function_t*)ptr(b);
d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
if (numval(d) != 0) return d;
ca = eq_class(table, a);
cb = eq_class(table, b);
if (ca!=NIL && ca==cb)
return fixnum(0);
eq_union(table, a, b, ca, cb);
d = cyc_compare(fa->vals, fb->vals, table, eq);
if (numval(d) != 0) return d;
a = fa->env;
b = fb->env;
goto cyc_compare_top;
}
return bounded_compare(a, b, 1, eq);
}

331
femtolisp/flisp.boot
View File

File diff suppressed because one or more lines are too long

27
femtolisp/flisp.c
View File

@ -224,6 +224,11 @@ SAFECAST_OP(string,char*, cvalue_data)
symbol_t *symtab = NULL;
int fl_is_keyword_name(char *str, size_t len)
{
return ((str[0] == ':' || str[len-1] == ':') && str[1] != '\0');
}
static symbol_t *mk_symbol(char *str)
{
symbol_t *sym;
@ -232,7 +237,7 @@ static symbol_t *mk_symbol(char *str)
sym = (symbol_t*)malloc(sizeof(symbol_t)-sizeof(void*) + len + 1);
assert(((uptrint_t)sym & 0x7) == 0); // make sure malloc aligns 8
sym->left = sym->right = NULL;
if (str[0] == ':') {
if (fl_is_keyword_name(str, len)) {
value_t s = tagptr(sym, TAG_SYM);
setc(s, s);
}
@ -774,11 +779,6 @@ static value_t do_trycatch()
return v;
}
#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])
#define fn_name(f) (((value_t*)ptr(f))[3])
#if _BYTE_ORDER == __BIG_ENDIAN
#define GET_INT32(a) \
((((int32_t)a[0])<<0) | \
@ -2050,7 +2050,7 @@ extern value_t fl_file(value_t *args, uint32_t nargs);
int main(int argc, char *argv[])
{
value_t e, v;
value_t e;
int saveSP;
symbol_t *sym;
char fname_buf[1024];
@ -2083,10 +2083,15 @@ int main(int argc, char *argv[])
SP = saveSP;
}
else {
// stage 1 format: symbol/value pairs
sym = tosymbol(e, "bootstrap");
v = read_sexpr(Stack[SP-1]);
sym->binding = v;
// stage 1 format: list alternating symbol/value
while (iscons(e)) {
sym = tosymbol(car_(e), "bootstrap");
e = cdr_(e);
(void)tocons(e, "bootstrap");
sym->binding = car_(e);
e = cdr_(e);
}
break;
}
}
ios_close(value2c(ios_t*,Stack[SP-1]));

5
femtolisp/flisp.h
View File

@ -81,6 +81,10 @@ typedef struct _symbol_t {
#define cdr_(v) (((cons_t*)ptr(v))->cdr)
#define car(v) (tocons((v),"car")->car)
#define cdr(v) (tocons((v),"cdr")->cdr)
#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])
#define fn_name(f) (((value_t*)ptr(f))[3])
#define set(s, v) (((symbol_t*)ptr(s))->binding = (v))
#define setc(s, v) do { ((symbol_t*)ptr(s))->isconst = 1; \
@ -135,6 +139,7 @@ value_t list2(value_t a, value_t b);
value_t listn(size_t n, ...);
value_t symbol(char *str);
char *symbol_name(value_t v);
int fl_is_keyword_name(char *str, size_t len);
value_t alloc_vector(size_t n, int init);
size_t llength(value_t v);
value_t compare(value_t a, value_t b); // -1, 0, or 1

35
femtolisp/system.lsp
View File

@ -35,8 +35,8 @@
(define (mapn f lsts)
(if (null? (car lsts))
()
(cons (apply f (map1 car lsts))
(mapn f (map1 cdr lsts)))))
(cons (apply f (map1 car lsts (list ())))
(mapn f (map1 cdr lsts (list ()))))))
(if (null? lsts)
(map1 f lst (list ()))
(mapn f (cons lst lsts))))
@ -158,6 +158,19 @@
(define (cdddr x) (cdr (cdr (cdr x))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(let ((*values* (list '*values*)))
(set! values
(lambda vs
(if (and (pair? vs) (null? (cdr vs)))
(car vs)
(cons *values* vs))))
(set! call-with-values
(lambda (producer consumer)
(let ((res (producer)))
(if (and (pair? res) (eq? *values* (car res)))
(apply consumer (cdr res))
(consumer res))))))
; list utilities --------------------------------------------------------------
(define (every pred lst)
@ -401,6 +414,11 @@
(,loop ,@steps))))))
(,loop ,@inits))))
; SRFI 8
(define-macro (receive formals expr . body)
`(call-with-values (lambda () ,expr)
(lambda ,formals ,@body)))
(define-macro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
@ -807,18 +825,17 @@
(pp *print-pretty*))
(set! *print-pretty* #f)
(unwind-protect
(for-each (lambda (s)
(if (and (bound? s)
(let ((syms (filter (lambda (s)
(and (bound? s)
(not (constant? s))
(or (not (builtin? (top-level-value s)))
(not (equal? (string s) ; alias of builtin
(string (top-level-value s)))))
(not (memq s excludes))
(not (iostream? (top-level-value s))))
(begin
(io.print f s) (io.write f "\n")
(io.print f (top-level-value s)) (io.write f "\n"))))
(reverse! (simple-sort (environment))))
(not (iostream? (top-level-value s)))))
(simple-sort (environment)))))
(io.print f (apply nconc (map list syms (map top-level-value syms))))
(io.write f *linefeed*))
(begin
(io.close f)
(set! *print-pretty* pp)))))

9
femtolisp/todo
View File

@ -976,6 +976,8 @@ consolidated todo list as of 7/8:
- remaining c types
- remaining cvalues functions
- finish ios
- optional and keyword arguments
- some kind of record, struct, or object system
- special efficient reader for #array
- reimplement vectors as (array lispvalue)
@ -1037,11 +1039,12 @@ new evaluator todo:
. largs instruction to move args after MAX_ARGS from list to stack
* maxstack calculation, make Stack growable
* stack traces and better debugging support
- make maxstack calculation robust against invalid bytecode
- let eversion
- lambda lifting
* lambda lifting
* let optimization
- fix equal? on functions
- store function name
* fix equal? on functions
* store function name
* have macroexpand use its own global syntax table
* be able to create/load an image file
* fix trace and untrace