adding new "translucent" function type for byte-compiled lambdas

femtolisp/builtins.c

@@ -147,7 +147,7 @@ static value_t fl_set_top_level_value(value_t *args, u_int32_t nargs)
     return args[1];
 }
 
-extern value_t LAMBDA, COMPILEDLAMBDA;
+extern value_t LAMBDA;
 
 static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
 {
@@ -160,8 +160,8 @@ static value_t fl_setsyntax(value_t *args, u_int32_t nargs)
         sym->syntax = 0;
     }
     else {
-        if (!iscons(args[1]) || (car_(args[1])!=LAMBDA &&
+        if (!iscvalue(args[1]) &&
-                                 car_(args[1])!=COMPILEDLAMBDA))
+            (!iscons(args[1]) || car_(args[1])!=LAMBDA))
             type_error("set-syntax!", "function", args[1]);
         sym->syntax = args[1];
     }

femtolisp/compiler.lsp

@@ -153,13 +153,6 @@
 		     const-to-idx)
       cvec)))
 
-(define (bytecode g)
-  (cons (cvalue.pin (encode-byte-code (aref g 0)))
-	(const-to-idx-vec g)))
-
-(define (bytecode:code b) (car b))
-(define (bytecode:vals b) (cdr b))
-
 (define (index-of item lst start)
   (cond ((null? lst) #f)
 	((eq item (car lst)) start)
@@ -426,7 +419,8 @@
 	  (else  (emit g :vargc (if (atom? args) 0 (length args)))))
     (compile-in g (cons (to-proper args) env) #t (caddr f))
     (emit g :ret)
-    `(compiled-lambda ,args ,(bytecode g))))
+    (function (encode-byte-code (aref g 0))
+	      (const-to-idx-vec g))))
 
 (define (compile f) (compile-f () f))
 
@@ -445,12 +439,10 @@
 (define (hex5 n)
   (pad-l (number->string n 16) 5 #\0))
 
-(define (disassemble- b lev)
+(define (disassemble- f lev)
-  (if (and (pair? b)
+  (let ((fvec (function->vector f)))
-	   (eq? (car b) 'compiled-lambda))
+    (let ((code (aref fvec 0))
-      (disassemble- (caddr b) lev)
+	  (vals (aref fvec 1)))
-      (let ((code (bytecode:code b))
-	    (vals (bytecode:vals b)))
       (define (print-val v)
 	(if (and (pair? v) (eq? (car v) 'compiled-lambda))
 	    (begin (princ "\n")
@@ -495,6 +487,6 @@
 		   
 		   (else #f))))))))
 
-(define (disassemble b) (disassemble- b 0) (newline))
+(define (disassemble f) (disassemble- f 0) (newline))
 
 #t

femtolisp/cvalues.c

@@ -78,6 +78,9 @@ static void sweep_finalizers()
                 t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
             }
             if (!isinlined(tmp) && owned(tmp)) {
+#ifndef NDEBUG
+                memset(cv_data(tmp), 0xbb, cv_len(tmp));
+#endif
                 free(cv_data(tmp));
             }
             ndel++;
@@ -709,15 +712,6 @@ value_t fl_podp(value_t *args, u_int32_t nargs)
         FL_T : FL_F;
 }
 
-value_t fl_cv_pin(value_t *args, u_int32_t nargs)
-{
-    argcount("cvalue.pin", nargs, 1);
-    if (!iscvalue(args[0]))
-        lerror(ArgError, "cvalue.pin: must be a byte array");
-    cv_pin((cvalue_t*)ptr(args[0]));
-    return args[0];
-}
-
 static void cvalue_init(fltype_t *type, value_t v, void *dest)
 {
     cvinitfunc_t f=type->init;
@@ -922,7 +916,6 @@ static builtinspec_t cvalues_builtin_info[] = {
     { "sizeof", cvalue_sizeof },
     { "builtin", fl_builtin },
     { "copy", fl_copy },
-    { "cvalue.pin", fl_cv_pin },
     { "plain-old-data?", fl_podp },
 
     { "logand", fl_logand },

femtolisp/flisp.c

@@ -99,12 +99,13 @@ stackseg_t stackseg0 = { StaticStack, 0, NULL };
 stackseg_t *current_stack_seg = &stackseg0;
 
 value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH;
-value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, COMPILEDLAMBDA;
+value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
 value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
 value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
 value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
 value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
 value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym;
+static fltype_t *functiontype;
 
 static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz);
 static value_t apply_cl(uint32_t nargs);
@@ -470,7 +471,7 @@ static void trace_globals(symbol_t *root)
     while (root != NULL) {
         if (root->binding != UNBOUND)
             root->binding = relocate(root->binding);
-        if (iscons(root->syntax))
+        if (iscons(root->syntax) || iscvalue(root->syntax))
             root->syntax = relocate(root->syntax);
         trace_globals(root->left);
         root = root->right;
@@ -1441,8 +1442,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
     }
     f = Stack[bp+1];
     assert((signed)SP > (signed)bp+1);
-    if (__likely(iscons(f))) {
+    if (isfunction(f)) {
-        if (car_(f) == COMPILEDLAMBDA) {
         i = SP;
         e = apply_cl(nargs);
         SP = i;
@@ -1456,6 +1456,7 @@ static value_t eval_sexpr(value_t e, value_t *penv, int tail, uint32_t envsz)
             return e;
         }
     }
+    else if (__likely(iscons(f))) {
         // apply lambda expression
         f = Stack[bp+1] = cdr_(f);
         if (!iscons(f)) goto notpair;
@@ -1550,7 +1551,8 @@ static value_t apply_cl(uint32_t nargs)
     fixnum_t s, lo, hi;
     int64_t accum;
     uint8_t *code;
-    value_t func, v, bcode, x, e;
+    value_t func, v, x, e;
+    function_t *fn;
     value_t *pvals, *lenv, *pv;
     symbol_t *sym;
     cons_t *c;
@@ -1558,20 +1560,17 @@ static value_t apply_cl(uint32_t nargs)
  apply_cl_top:
     captured = 0;
     func = Stack[SP-nargs-1];
-    assert(iscons(func));
+    fn = value2c(function_t*,func);
-    assert(iscons(cdr_(func)));
+    code = cv_data((cvalue_t*)ptr(fn->bcode));
-    assert(iscons(cdr_(cdr_(func))));
-    x = cdr_(cdr_(func));
-    bcode = car_(x);
-    code = cv_data((cvalue_t*)ptr(car_(bcode)));
     assert(!ismanaged((uptrint_t)code));
+    assert(ismanaged(func));
+    assert(ismanaged(fn->bcode));
     if (nargs < code[1])
         lerror(ArgError, "apply: too few arguments");
 
     bp = SP-nargs;
-    x = cdr_(x);   // cloenv
+    PUSH(fn->env);
-    PUSH(x);
+    PUSH(fn->vals);
-    PUSH(cdr_(bcode));
     pvals = &Stack[SP-1];
 
     ip = 0;
@@ -1653,8 +1652,7 @@ static value_t apply_cl(uint32_t nargs)
                     }
                 }
             }
-            else if (iscons(func)) {
+            else if (isfunction(func)) {
-                if (car_(func) == COMPILEDLAMBDA) {
                 if (op == OP_TCALL) {
                     for(s=-1; s < (fixnum_t)i; s++)
                         Stack[bp+s] = Stack[SP-i+s];
@@ -1666,10 +1664,9 @@ static value_t apply_cl(uint32_t nargs)
                     v = apply_cl(i);
                 }
             }
-                else {
+            else if (iscons(func)) {
                 v = _applyn(i);
             }
-            }
             else {
                 type_error("apply", "function", func);
             }
@@ -2140,19 +2137,20 @@ static value_t apply_cl(uint32_t nargs)
                 PUSH(Stack[bp]); // env has already been captured; share
             }
             if (op == OP_CLOSURE) {
-              c = (cons_t*)ptr(v=cons_reserve(3));
+                pv = alloc_words(6);
-              e = cdr_(Stack[SP-2]);  // closure to copy
+                x = Stack[SP-2];  // closure to copy
-              //if (!iscons(e)) goto notpair;
+                assert(isfunction(x));
-              c->car = COMPILEDLAMBDA;
+                pv[0] = ((value_t*)ptr(x))[0];
-              c->cdr = tagptr(c+1, TAG_CONS); c++;
+                assert(pv[0] == functiontype);
-              c->car = car_(e);      //argsyms
+                pv[1] = (value_t)&pv[3];
-              c->cdr = tagptr(c+1, TAG_CONS); c++;
+                pv[2] = ((value_t*)ptr(x))[2];
-              e = cdr_(e);
+                pv[3] = ((value_t*)ptr(x))[3];
-              //if (!iscons(e=cdr_(e))) goto notpair;
+                assert(isstring(pv[3]));
-              c->car = car_(e);      //body
+                pv[4] = ((value_t*)ptr(x))[4];
-              c->cdr = Stack[SP-1];  //env
+                assert(isvector(pv[4]));
+                pv[5] = Stack[SP-1];  // env
                 POPN(1);
-              Stack[SP-1] = v;
+                Stack[SP-1] = tagptr(pv, TAG_CVALUE);
             }
             break;
 
@@ -2180,6 +2178,80 @@ void assign_global_builtins(builtinspec_t *b)
     }
 }
 
+static void print_function(value_t v, ios_t *f, int princ)
+{
+    (void)princ;
+    function_t *fn = value2c(function_t*,v);
+    outs("#function(", f);
+    int newindent = HPOS;
+    fl_print_child(f, fn->bcode, 0); outindent(newindent, f);
+    fl_print_child(f, fn->vals, 0);  outindent(newindent, f);
+    fl_print_child(f, fn->env, 0);
+    outc(')', f);
+}
+
+static void print_traverse_function(value_t v)
+{
+    function_t *fn = value2c(function_t*,v);
+    print_traverse(fn->bcode);
+    print_traverse(fn->vals);
+    print_traverse(fn->env);
+}
+
+static void relocate_function(value_t oldv, value_t newv)
+{
+    (void)oldv;
+    function_t *fn = value2c(function_t*,newv);
+    fn->bcode = relocate(fn->bcode);
+    fn->vals = relocate(fn->vals);
+    fn->env = relocate(fn->env);
+}
+
+static value_t fl_function(value_t *args, uint32_t nargs)
+{
+    if (nargs != 3)
+        argcount("function", nargs, 2);
+    if (!isstring(args[0]))
+        type_error("function", "string", args[0]);
+    if (!isvector(args[1]))
+        type_error("function", "vector", args[1]);
+    cv_pin((cvalue_t*)ptr(args[0]));
+    value_t fv = cvalue(functiontype, sizeof(function_t));
+    function_t *fn = value2c(function_t*,fv);
+    fn->bcode = args[0];
+    fn->vals = args[1];
+    if (nargs == 3)
+        fn->env = args[2];
+    else
+        fn->env = NIL;
+    return fv;
+}
+
+static value_t fl_function2vector(value_t *args, uint32_t nargs)
+{
+    argcount("function->vector", nargs, 1);
+    value_t v = args[0];
+    if (!iscvalue(v) || cv_class((cvalue_t*)ptr(v)) != functiontype)
+        type_error("function->vector", "function", v);
+    value_t vec = alloc_vector(3, 0);
+    function_t *fn = value2c(function_t*,args[0]);
+    vector_elt(vec,0) = fn->bcode;
+    vector_elt(vec,1) = fn->vals;
+    vector_elt(vec,2) = fn->env;
+    return vec;
+}
+
+static cvtable_t function_vtable = { print_function, relocate_function,
+                                     NULL, print_traverse_function };
+
+static builtinspec_t core_builtin_info[] = {
+    { "function", fl_function },
+    { "function->vector", fl_function2vector },
+    { "gensym", gensym },
+    { "hash", fl_hash },
+    { NULL, NULL }
+};
+
 static void lisp_init(void)
 {
     int i;
@@ -2198,7 +2270,7 @@ static void lisp_init(void)
     FL_T = builtin(F_TRUE);
     FL_F = builtin(F_FALSE);
     LAMBDA = symbol("lambda");
-    COMPILEDLAMBDA = symbol("compiled-lambda");
+    FUNCTION = symbol("function");
     QUOTE = symbol("quote");
     TRYCATCH = symbol("trycatch");
     BACKQUOTE = symbol("backquote");
@@ -2259,8 +2331,6 @@ static void lisp_init(void)
 #endif
 
     cvalues_init();
-    set(symbol("gensym"), cbuiltin("gensym", gensym));
-    set(symbol("hash"), cbuiltin("hash", fl_hash));
 
     char buf[1024];
     char *exename = get_exename(buf, sizeof(buf));
@@ -2273,6 +2343,11 @@ static void lisp_init(void)
     memory_exception_value = list2(MemoryError,
                                    cvalue_static_cstring("out of memory"));
 
+    functiontype = define_opaque_type(FUNCTION, sizeof(function_t),
+                                      &function_vtable, NULL);
+
+    assign_global_builtins(core_builtin_info);
+
     builtins_init();
 }
 

femtolisp/flisp.h

@@ -93,6 +93,8 @@ typedef struct _symbol_t {
                       (((unsigned char*)ptr(v)) < fromspace+heapsize))
 #define isgensym(x)  (issymbol(x) && ismanaged(x))
 
+#define isfunction(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==functiontype))
+
 extern value_t *Stack;
 extern uint32_t SP;
 #define PUSH(v) (Stack[SP++] = (v))
@@ -223,6 +225,12 @@ typedef struct {
     char _space[1];
 } cprim_t;
 
+typedef struct {
+    value_t bcode;
+    value_t vals;
+    value_t env;
+} function_t;
+
 #define CPRIM_NWORDS 2
 #define MAX_INL_SIZE 96
 

femtolisp/read.c

@@ -551,8 +551,10 @@ static value_t do_read_sexpr(value_t label)
         }
         PUSH(NIL);
         read_list(&Stack[SP-1], UNBOUND);
-        v = POP();
+        v = symbol_value(sym);
-        return apply(toplevel_eval(sym), v);
+        if (v == UNBOUND)
+            raise(list2(UnboundError, sym));
+        return apply(v, POP());
     case TOK_OPENB:
         return read_vector(label, TOK_CLOSEB);
     case TOK_SHARPOPEN:

femtolisp/system.lsp

@@ -102,8 +102,8 @@
 (define (char? x) (eq? (typeof x) 'wchar))
 (define (function? x)
   (or (builtin? x)
-      (and (pair? x) (or (eq (car x) 'lambda)
+      (eq (typeof x) 'function)
-			 (eq (car x) 'compiled-lambda)))))
+      (and (pair? x) (eq (car x) 'lambda))))
 (define procedure? function?)
 
 (define (caar x) (car (car x)))

femtolisp/todo

@@ -1018,7 +1018,7 @@ typedef struct _fltype_t {
 new evaluator todo:
 
 * need builtin = to handle nans properly, fix equal? on nans
-- builtin quasi-opaque function type
+* builtin quasi-opaque function type
   fields: signature, maxstack, bcode, vals, cloenv
   function->vector
 * make (for ...) a special form