adding branch probability annotations

wrote a CPS transformer that can be used to provide coroutines

misc. cleanup

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 },
 

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
+|#

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;
+    return cvalue(stringtype, sz);
-    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;
 }
 
 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;

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]);

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<c ? "few":"many");
 }
 

femtolisp/string.c

@@ -35,14 +35,6 @@ static value_t print_to_string(value_t v, int princ)
     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 @@ value_t fl_string_dec(value_t *args, u_int32_t nargs)
 }
 
 static builtinspec_t stringfunc_info[] = {
-    { "intern", fl_intern },
     { "string", fl_string },
     { "stringp", fl_stringp },
     { "string.length", fl_string_length },

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))))

femtolisp/todo

@@ -832,21 +832,22 @@ IOStream API
  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 @@ consolidated todo list as of 8/30:
 - expose io stream object
 - new toplevel
 
-- enable print-shared for cvalues' types
 - remaining c types
 - remaining cvalues functions
 - finish ios

llt/dtypes.h

@@ -87,6 +87,15 @@ typedef u_ptrint_t uptrint_t;
 
 #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