diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 8f43dc3..9f67f74 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -73,6 +73,14 @@ value_t fl_exit(value_t *args, u_int32_t nargs) return NIL; } +value_t fl_intern(value_t *args, u_int32_t nargs) +{ + argcount("intern", nargs, 1); + if (!isstring(args[0])) + type_error("intern", "string", args[0]); + return symbol(cvalue_data(args[0])); +} + extern value_t LAMBDA; value_t fl_setsyntax(value_t *args, u_int32_t nargs) @@ -241,7 +249,7 @@ value_t fl_time_now(value_t *args, u_int32_t nargs) return mk_double(clock_now()); } -static double value_to_double(value_t a, char *fname) +static double todouble(value_t a, char *fname) { if (isfixnum(a)) return (double)numval(a); @@ -257,7 +265,7 @@ static double value_to_double(value_t a, char *fname) value_t fl_time_string(value_t *args, uint32_t nargs) { argcount("time.string", nargs, 1); - double t = value_to_double(args[0], "time.string"); + double t = todouble(args[0], "time.string"); char buf[64]; timestring(t, buf, sizeof(buf)); return string_from_cstr(buf); @@ -359,6 +367,7 @@ static builtinspec_t builtin_info[] = { { "read", fl_read }, { "load", fl_load }, { "exit", fl_exit }, + { "intern", fl_intern }, { "fixnum", fl_fixnum }, { "truncate", fl_truncate }, diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp new file mode 100644 index 0000000..d8c2999 --- /dev/null +++ b/femtolisp/cps.lsp @@ -0,0 +1,167 @@ +(define (cond->if form) + (cond-clauses->if (cdr form))) +(define (cond-clauses->if lst) + (if (atom lst) + lst + (let ((clause (car lst))) + `(if ,(car clause) + ,(f-body (cdr clause)) + ,(cond-clauses->if (cdr lst)))))) + +(define (progn->cps forms k) + (cond ((atom forms) `(,k ,forms)) + ((null (cdr forms)) (cps- (car forms) k)) + (T (let ((_ (gensym))) ; var to bind ignored value + (cps- (car forms) `(lambda (,_) + ,(progn->cps (cdr forms) k))))))) + +(define (rest->cps xformer form k argsyms) + (let ((g (gensym))) + (cps- (car form) `(lambda (,g) + ,(xformer (cdr form) k (cons g argsyms)))))) + +; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X))))) +(define (app->cps form k argsyms) + (cond ((atom form) + (let ((r (reverse argsyms))) + `(,(car r) ,k ,@(cdr r)))) + (T (rest->cps app->cps form k argsyms)))) + +; (+ x) => (cps- x `(lambda (X) (,k (+ X)))) +(define (builtincall->cps form k) + (prim->cps (cdr form) k (list (car form)))) +(define (prim->cps form k argsyms) + (cond ((atom form) `(,k ,(reverse argsyms))) + (T (rest->cps prim->cps form k argsyms)))) + +(define (cps form) + (η-reduce + (β-reduce + (macroexpand + (cps- (macroexpand form) 'identity))))) +(define (cps- form k) + (let ((g (gensym))) + (cond ((or (atom form) (constantp form)) + `(,k ,form)) + + ((eq (car form) 'lambda) + `(,k (lambda ,(cons g (cadr form)) ,(cps- (caddr form) g)))) + + ((eq (car form) 'progn) + (progn->cps (cdr form) k)) + + ((eq (car form) 'cond) + (cps- (cond->if form) k)) + + ((eq (car form) 'if) + (let ((test (cadr form)) + (then (caddr form)) + (else (cadddr form))) + (if (atom k) + (cps- test `(lambda (,g) + (if ,g + ,(cps- then k) + ,(cps- else k)))) + `(let ((,g ,k)) + ,(cps- form g))))) + + ((eq (car form) 'setq) + (let ((var (cadr form)) + (E (caddr form))) + (cps- E `(lambda (,g) (,k (setq ,var ,g)))))) + + ((eq (car form) 'reset) + `(,k ,(cps- (cadr form) 'identity))) + + ((eq (car form) 'shift) + (let ((v (cadr form)) + (E (caddr form))) + `(let ((,v (lambda (ignored-k val) (,k val)))) + ,(cps- E 'identity)))) + + ((and (constantp (car form)) + (builtinp (eval (car form)))) + (builtincall->cps form k)) + + ; ((lambda (...) body) ...) + ((and (consp (car form)) + (eq (caar form) 'lambda)) + (let ((largs (cadr (car form))) + (lbody (caddr (car form)))) + (if (null largs) + (cps- lbody k) ; ((lambda () x)) + (cps- (cadr form) `(lambda (,(car largs)) + ,(cps- `((lambda ,(cdr largs) ,lbody) + ,@(cddr form)) + k)))))) + + (T + (app->cps form k ()))))) + +; (lambda (args...) (f args...)) => f +(define (η-reduce form) + (cond ((or (atom form) (constantp form)) form) + ((and (eq (car form) 'lambda) + (let ((body (caddr form)) + (args (cadr form))) + (and (consp body) + (equal (cdr body) args)))) + (η-reduce (car (caddr form)))) + (T (map η-reduce form)))) + +; ((lambda (f) (f arg)) X) => (X arg) +(define (β-reduce form) + (cond ((or (atom form) (constantp form)) form) + ((and (= (length form) 2) + (consp (car form)) + (eq (caar form) 'lambda) + (let ((args (cadr (car form))) + (body (caddr (car form)))) + (and (= (length body) 2) + (= (length args) 1) + (eq (car body) (car args)) + (not (eq (cadr body) (car args))) + (symbolp (cadr body))))) + `(,(β-reduce (cadr form)) + ,(cadr (caddr (car form))))) + (T (map β-reduce form)))) + +(defmacro with-delimited-continuations (exp) (cps exp)) + +(defmacro defgenerator (name args . body) + (let ((ko (gensym)) + (cur (gensym))) + `(defun ,name ,args + (let ((,ko ()) + (,cur ())) + (lambda () + (with-delimited-continuations + (if ,ko (,ko ,cur) + (reset + (let ((yield + (lambda (v) + (shift yk + (progn (setq ,ko yk) + (setq ,cur v)))))) + ,(f-body body)))))))))) + +; a test case +(defgenerator range-iterator (lo hi) + ((label loop + (lambda (i) + (if (< hi i) + 'done + (progn (yield i) + (loop (+ 1 i)))))) + lo)) + +T + +#| +todo: +- tag lambdas that accept continuation arguments, compile computed + calls to calls to funcall/cc that does the right thing for both + cc-lambdas and normal lambdas + +- handle while, and, or +|# diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index d1e9722..1139060 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -120,7 +120,14 @@ void cv_autorelease(cvalue_t *cv) value_t cvalue(fltype_t *type, size_t sz) { cvalue_t *pcv; + int str=0; + if (type->eltype == bytetype) { + if (sz == 0) + return symbol_value(emptystringsym); + sz++; + str=1; + } if (sz <= MAX_INL_SIZE) { size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz==0 ? 1 : 0); pcv = (cvalue_t*)alloc_words(nw); @@ -138,6 +145,10 @@ value_t cvalue(fltype_t *type, size_t sz) autorelease(pcv); malloc_pressure += sz; } + if (str) { + sz--; + ((char*)pcv->data)[sz] = '\0'; + } pcv->len = sz; return tagptr(pcv, TAG_CVALUE); } @@ -179,20 +190,7 @@ value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent) value_t cvalue_string(size_t sz) { - value_t cv; - char *data; - cvalue_t *pcv; - - if (sz == 0) - return symbol_value(emptystringsym); - // secretly allocate space for 1 more byte, hide a NUL there so - // any string will always be NUL terminated. - cv = cvalue(stringtype, sz+1); - pcv = (cvalue_t*)ptr(cv); - data = cv_data(pcv); - data[sz] = '\0'; - pcv->len = sz; - return cv; + return cvalue(stringtype, sz); } value_t cvalue_static_cstring(char *str) @@ -449,18 +447,6 @@ static void cvalue_array_init(fltype_t *ft, value_t arg, void *dest) type_error("array", "sequence", arg); } -static value_t alloc_array(fltype_t *type, size_t sz) -{ - value_t cv; - if (type->eltype == bytetype) { - cv = cvalue_string(sz); - } - else { - cv = cvalue(type, sz); - } - return cv; -} - value_t cvalue_array(value_t *args, u_int32_t nargs) { size_t elsize, cnt, sz; @@ -473,7 +459,7 @@ value_t cvalue_array(value_t *args, u_int32_t nargs) elsize = type->elsz; sz = elsize * cnt; - value_t cv = alloc_array(type, sz); + value_t cv = cvalue(type, sz); array_init_fromargs(cv_data((cvalue_t*)ptr(cv)), &args[1], cnt, type->eltype, elsize); return cv; @@ -727,7 +713,7 @@ value_t cvalue_new(value_t *args, u_int32_t nargs) cnt = predict_arraylen(args[1]); else cnt = 0; - cv = alloc_array(ft, elsz * cnt); + cv = cvalue(ft, elsz * cnt); if (nargs == 2) cvalue_array_init(ft, args[1], cv_data((cvalue_t*)ptr(cv))); } @@ -771,18 +757,11 @@ static void check_addr_args(char *fname, value_t arr, value_t ind, bounds_error(fname, arr, ind); } -static value_t make_uninitialized_instance(fltype_t *t) -{ - if (t->eltype != NULL) - return alloc_array(t, t->size); - return cvalue(t, t->size); -} - static value_t cvalue_array_aref(value_t *args) { char *data; ulong_t index; fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype; - value_t el = make_uninitialized_instance(eltype); + value_t el = cvalue(eltype, eltype->size); check_addr_args("aref", args[0], args[1], &data, &index); char *dest = cv_data((cvalue_t*)ptr(el)); size_t sz = eltype->size; diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index e3e2b67..39ca59b 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -167,10 +167,9 @@ void bounds_error(char *fname, value_t arr, value_t ind) #define SAFECAST_OP(type,ctype,cnvt) \ ctype to##type(value_t v, char *fname) \ { \ - if (is##type(v)) \ + if (__likely(is##type(v))) \ return (ctype)cnvt(v); \ type_error(fname, #type, v); \ - return (ctype)0; \ } SAFECAST_OP(cons, cons_t*, ptr) SAFECAST_OP(symbol,symbol_t*,ptr) @@ -290,7 +289,7 @@ static value_t mk_cons(void) { cons_t *c; - if (curheap > lim) + if (__unlikely(curheap > lim)) gc(0); c = (cons_t*)curheap; curheap += sizeof(cons_t); @@ -303,7 +302,7 @@ static value_t *alloc_words(int n) assert(n > 0); n = ALIGN(n, 2); // only allocate multiples of 2 words - if ((value_t*)curheap > ((value_t*)lim)+2-n) { + if (__unlikely((value_t*)curheap > ((value_t*)lim)+2-n)) { gc(0); while ((value_t*)curheap > ((value_t*)lim)+2-n) { gc(1); @@ -672,11 +671,11 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) if (*pv == NIL) break; pv = &vector_elt(*pv, 0); } - if ((v = sym->binding) == UNBOUND) + if (__unlikely((v = sym->binding) == UNBOUND)) raise(list2(UnboundError, e)); return v; } - if (SP >= (N_STACK-64)) + if (__unlikely(SP >= (N_STACK-64))) lerror(MemoryError, "eval: stack overflow"); saveSP = SP; v = car_(e); @@ -707,7 +706,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) switch (uintval(f)) { // special forms case F_QUOTE: - if (!iscons(Stack[saveSP])) + if (__unlikely(!iscons(Stack[saveSP]))) lerror(ArgError, "quote: expected argument"); v = car_(Stack[saveSP]); break; @@ -926,7 +925,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) v = Stack[SP-2]; if (isvector(v)) { i = tofixnum(Stack[SP-1], "aref"); - if ((unsigned)i >= vector_size(v)) + if (__unlikely((unsigned)i >= vector_size(v))) bounds_error("aref", v, Stack[SP-1]); v = vector_elt(v, i); } @@ -943,7 +942,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) e = Stack[SP-3]; if (isvector(e)) { i = tofixnum(Stack[SP-2], "aset"); - if ((unsigned)i >= vector_size(e)) + if (__unlikely((unsigned)i >= vector_size(e))) bounds_error("aref", v, Stack[SP-1]); vector_elt(e, i) = (v=Stack[SP-1]); } @@ -992,9 +991,9 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) case F_ADD: s = 0; for (i=saveSP+1; i < (int)SP; i++) { - if (isfixnum(Stack[i])) { + if (__likely(isfixnum(Stack[i]))) { s += numval(Stack[i]); - if (!fits_fixnum(s)) { + if (__unlikely(!fits_fixnum(s))) { i++; goto add_ovf; } @@ -1009,19 +1008,19 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) v = fixnum(s); break; case F_SUB: - if (nargs < 1) lerror(ArgError, "-: too few arguments"); + if (__unlikely(nargs < 1)) lerror(ArgError, "-: too few arguments"); i = saveSP+1; if (nargs == 1) { - if (isfixnum(Stack[i])) + if (__likely(isfixnum(Stack[i]))) v = fixnum(-numval(Stack[i])); else v = fl_neg(Stack[i]); break; } if (nargs == 2) { - if (bothfixnums(Stack[i], Stack[i+1])) { + if (__likely(bothfixnums(Stack[i], Stack[i+1]))) { s = numval(Stack[i]) - numval(Stack[i+1]); - if (fits_fixnum(s)) { + if (__likely(fits_fixnum(s))) { v = fixnum(s); break; } @@ -1039,7 +1038,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) case F_MUL: accum = 1; for (i=saveSP+1; i < (int)SP; i++) { - if (isfixnum(Stack[i])) { + if (__likely(isfixnum(Stack[i]))) { accum *= numval(Stack[i]); } else { @@ -1048,13 +1047,13 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) return v; } } - if (fits_fixnum(accum)) + if (__likely(fits_fixnum(accum))) v = fixnum(accum); else v = return_from_int64(accum); break; case F_DIV: - if (nargs < 1) lerror(ArgError, "/: too few arguments"); + if (__unlikely(nargs < 1)) lerror(ArgError, "/: too few arguments"); i = saveSP+1; if (nargs == 1) { v = fl_div2(fixnum(1), Stack[i]); @@ -1146,7 +1145,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_PROG1: // return first arg - if (nargs < 1) lerror(ArgError, "prog1: too few arguments"); + if (__unlikely(nargs < 1)) + lerror(ArgError, "prog1: too few arguments"); v = Stack[saveSP+1]; break; case F_ASSOC: @@ -1206,7 +1206,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) return v; } apply_lambda: - if (iscons(f)) { + if (__likely(iscons(f))) { // apply lambda expression f = cdr_(f); PUSH(f); @@ -1219,7 +1219,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) while (iscons(v)) { // bind args if (!iscons(*argsyms)) { - if (*argsyms == NIL) + if (__unlikely(*argsyms == NIL)) lerror(ArgError, "apply: too many arguments"); break; } @@ -1234,7 +1234,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) while (iscons(v)) { // bind args if (!iscons(*argsyms)) { - if (*argsyms == NIL) + if (__unlikely(*argsyms == NIL)) lerror(ArgError, "apply: too many arguments"); break; } @@ -1269,7 +1269,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) } } } - if (iscons(*argsyms)) { + if (__unlikely(iscons(*argsyms))) { lerror(ArgError, "apply: too few arguments"); } f = cdr_(Stack[saveSP+1]); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index c2efbd0..f5ed0c9 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -151,7 +151,7 @@ void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noret extern value_t ArgError, IOError, KeyError; static inline void argcount(char *fname, int nargs, int c) { - if (nargs != c) + if (__unlikely(nargs != c)) lerror(ArgError,"%s: too %s arguments", fname, nargs