ref: dc50df083ca50561084bf572f538ca76a9dd100e
parent: b99d8715ce8ea2f97f25d65b628421c49087e23c
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sun Dec 28 03:01:18 EST 2008
adding branch probability annotations wrote a CPS transformer that can be used to provide coroutines misc. cleanup
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -73,6 +73,14 @@
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 @@
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 @@
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 @@
{ "read", fl_read }, { "load", fl_load }, { "exit", fl_exit },+ { "intern", fl_intern }, { "fixnum", fl_fixnum }, { "truncate", fl_truncate },--- /dev/null
+++ b/femtolisp/cps.lsp
@@ -1,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
+|#
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -120,7 +120,14 @@
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 @@
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_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 @@
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 @@
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 @@
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 @@
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;
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -167,10 +167,9 @@
#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 @@
{cons_t *c;
- if (curheap > lim)
+ if (__unlikely(curheap > lim))
gc(0);
c = (cons_t*)curheap;
curheap += sizeof(cons_t);
@@ -303,7 +302,7 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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,10 +1008,10 @@
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]);
@@ -1019,9 +1018,9 @@
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 @@
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 @@
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 @@
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 @@
return v;
}
apply_lambda:
- if (iscons(f)) {+ if (__likely(iscons(f))) {// apply lambda expression
f = cdr_(f);
PUSH(f);
@@ -1219,7 +1219,7 @@
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 @@
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 @@
}
}
}
- if (iscons(*argsyms)) {+ if (__unlikely(iscons(*argsyms))) {lerror(ArgError, "apply: too few arguments");
}
f = cdr_(Stack[saveSP+1]);
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -151,7 +151,7 @@
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<c ? "few":"many");
}
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -35,14 +35,6 @@
return outp;
}
-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]));
-}
-
value_t fl_stringp(value_t *args, u_int32_t nargs)
{ argcount("stringp", nargs, 1);@@ -350,7 +342,6 @@
}
static builtinspec_t stringfunc_info[] = {- { "intern", fl_intern }, { "string", fl_string }, { "stringp", fl_stringp }, { "string.length", fl_string_length },--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -149,6 +149,7 @@
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -832,21 +832,22 @@
princ, sprinc
iostream - (stream[ cvalue-as-bytestream])
file
- fifo
- socket
stream.eof
stream.write - (stream.write s cvalue)
stream.read - (stream.read s ctype)
- stream.copy - (stream.copy to from [nbytes])
- stream.copyuntil - (stream.copy to from byte)
stream.flush
+ stream.close
stream.pos - (stream.pos s [set-pos])
stream.seek - (stream.seek s offset)
+ stream.getc - get utf8 character(s)
+ stream.readline
+ stream.copy - (stream.copy to from [nbytes])
+ stream.copyuntil - (stream.copy to from byte)
+ fifo
+ socket
stream.seekend - move to end of stream
stream.trunc
- stream.getc - get utf8 character(s)
stream.tostring! - destructively convert stringstream to string
- stream.readline
stream.readlines
stream.readall
print-to-string
@@ -931,7 +932,6 @@
- expose io stream object
- new toplevel
-- enable print-shared for cvalues' types
- remaining c types
- remaining cvalues functions
- finish ios
--- a/llt/dtypes.h
+++ b/llt/dtypes.h
@@ -87,6 +87,15 @@
#define ALIGN(x, sz) (((x) + (sz-1)) & (-sz))
+// branch prediction annotations
+#ifdef __GNUC__
+#define __unlikely(x) __builtin_expect(!!(x), 0)
+#define __likely(x) __builtin_expect(!!(x), 1)
+#else
+#define __unlikely(x) (x)
+#define __likely(x) (x)
+#endif
+
#define DBL_MAXINT 9007199254740992LL
#define FLT_MAXINT 16777216
#define U64_MAX 18446744073709551615ULL