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
parent
c19aaeabd6
commit
2c304edf42
|
|
@ -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 },
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -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]));
|
||||
|
|
|
|||
|
|
@ -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,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)
|
||||
(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))))
|
||||
(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)))))
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue