shithub: femtolisp

Download patch

ref: 5ab7a7c1e10e681ec792ffb7467f7250f374e88c
parent: aa62ae9e9640131f1ce4e158f7834878df7fd8eb
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sun Apr 19 18:22:17 EDT 2009

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


--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -147,7 +147,7 @@
     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 @@
         sym->syntax = 0;
     }
     else {
-        if (!iscons(args[1]) || (car_(args[1])!=LAMBDA &&
-                                 car_(args[1])!=COMPILEDLAMBDA))
+        if (!iscvalue(args[1]) &&
+            (!iscons(args[1]) || car_(args[1])!=LAMBDA))
             type_error("set-syntax!", "function", args[1]);
         sym->syntax = args[1];
     }
--- a/femtolisp/compiler.lsp
+++ b/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,56 +439,54 @@
 (define (hex5 n)
   (pad-l (number->string n 16) 5 #\0))
 
-(define (disassemble- b lev)
-  (if (and (pair? b)
-	   (eq? (car b) 'compiled-lambda))
-      (disassemble- (caddr b) lev)
-      (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")
-		     (disassemble- v (+ lev 1)))
-	      (print v)))
-	(let ((i 0)
-	      (N (length code)))
-	  (while (< i N)
-		 (let ((inst (get 1/Instructions (aref code i))))
-		   (if (> i 0) (newline))
-		   (dotimes (xx lev) (princ "\t"))
-		   (princ (hex5 i) ":  "
-			  (string.tail (string inst) 1) "\t")
-		   (set! i (+ i 1))
-		   (case inst
-		     ((:loadv.l :loadg.l :setg.l)
-		      (print-val (aref vals (ref-uint32-LE code i)))
-		      (set! i (+ i 4)))
+(define (disassemble- f lev)
+  (let ((fvec (function->vector f)))
+    (let ((code (aref fvec 0))
+	  (vals (aref fvec 1)))
+      (define (print-val v)
+	(if (and (pair? v) (eq? (car v) 'compiled-lambda))
+	    (begin (princ "\n")
+		   (disassemble- v (+ lev 1)))
+	    (print v)))
+      (let ((i 0)
+	    (N (length code)))
+	(while (< i N)
+	       (let ((inst (get 1/Instructions (aref code i))))
+		 (if (> i 0) (newline))
+		 (dotimes (xx lev) (princ "\t"))
+		 (princ (hex5 i) ":  "
+			(string.tail (string inst) 1) "\t")
+		 (set! i (+ i 1))
+		 (case inst
+		   ((:loadv.l :loadg.l :setg.l)
+		    (print-val (aref vals (ref-uint32-LE code i)))
+		    (set! i (+ i 4)))
+		   
+		   ((:loadv :loadg :setg)
+		    (print-val (aref vals (aref code i)))
+		    (set! i (+ i 1)))
+		   
+		   ((:loada :seta :call :tcall :list :+ :- :* :/ :vector
+			    :argc :vargc :loadi8 :let)
+		    (princ (number->string (aref code i)))
+		    (set! i (+ i 1)))
+		   
+		   ((:loadc :setc)
+		    (princ (number->string (aref code i)) " ")
+		    (set! i (+ i 1))
+		    (princ (number->string (aref code i)))
+		    (set! i (+ i 1)))
+		   
+		   ((:jmp :brf :brt)
+		    (princ "@" (hex5 (ref-uint16-LE code i)))
+		    (set! i (+ i 2)))
+		   
+		   ((:jmp.l :brf.l :brt.l)
+		    (princ "@" (hex5 (ref-uint32-LE code i)))
+		    (set! i (+ i 4)))
+		   
+		   (else #f))))))))
 
-		     ((:loadv :loadg :setg)
-		      (print-val (aref vals (aref code i)))
-		      (set! i (+ i 1)))
-
-		     ((:loada :seta :call :tcall :list :+ :- :* :/ :vector
-		       :argc :vargc :loadi8 :let)
-		      (princ (number->string (aref code i)))
-		      (set! i (+ i 1)))
-
-		     ((:loadc :setc)
-		      (princ (number->string (aref code i)) " ")
-		      (set! i (+ i 1))
-		      (princ (number->string (aref code i)))
-		      (set! i (+ i 1)))
-
-		     ((:jmp :brf :brt)
-		      (princ "@" (hex5 (ref-uint16-LE code i)))
-		      (set! i (+ i 2)))
-
-		     ((:jmp.l :brf.l :brt.l)
-		      (princ "@" (hex5 (ref-uint32-LE code i)))
-		      (set! i (+ i 4)))
-
-		     (else #f))))))))
-
-(define (disassemble b) (disassemble- b 0) (newline))
+(define (disassemble f) (disassemble- f 0) (newline))
 
 #t
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -78,6 +78,9 @@
                 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 @@
         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 @@
     { "sizeof", cvalue_sizeof },
     { "builtin", fl_builtin },
     { "copy", fl_copy },
-    { "cvalue.pin", fl_cv_pin },
     { "plain-old-data?", fl_podp },
 
     { "logand", fl_logand },
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -99,12 +99,13 @@
 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 @@
     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,21 +1442,21 @@
     }
     f = Stack[bp+1];
     assert((signed)SP > (signed)bp+1);
-    if (__likely(iscons(f))) {
-        if (car_(f) == COMPILEDLAMBDA) {
-            i = SP;
-            e = apply_cl(nargs);
-            SP = i;
-            if (noeval == 2) {
-                if (selfevaluating(e)) { SP=saveSP; return(e); }
-                noeval = 0;
-                goto eval_top;
-            }
-            else {
-                SP = saveSP;
-                return e;
-            }
+    if (isfunction(f)) {
+        i = SP;
+        e = apply_cl(nargs);
+        SP = i;
+        if (noeval == 2) {
+            if (selfevaluating(e)) { SP=saveSP; return(e); }
+            noeval = 0;
+            goto eval_top;
         }
+        else {
+            SP = saveSP;
+            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 @@
     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 @@
  apply_cl_top:
     captured = 0;
     func = Stack[SP-nargs-1];
-    assert(iscons(func));
-    assert(iscons(cdr_(func)));
-    assert(iscons(cdr_(cdr_(func))));
-    x = cdr_(cdr_(func));
-    bcode = car_(x);
-    code = cv_data((cvalue_t*)ptr(car_(bcode)));
+    fn = value2c(function_t*,func);
+    code = cv_data((cvalue_t*)ptr(fn->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(x);
-    PUSH(cdr_(bcode));
+    PUSH(fn->env);
+    PUSH(fn->vals);
     pvals = &Stack[SP-1];
 
     ip = 0;
@@ -1653,23 +1652,21 @@
                     }
                 }
             }
-            else if (iscons(func)) {
-                if (car_(func) == COMPILEDLAMBDA) {
-                    if (op == OP_TCALL) {
-                        for(s=-1; s < (fixnum_t)i; s++)
-                            Stack[bp+s] = Stack[SP-i+s];
-                        SP = bp+i;
-                        nargs = i;
-                        goto apply_cl_top;
-                    }
-                    else {
-                        v = apply_cl(i);
-                    }
+            else if (isfunction(func)) {
+                if (op == OP_TCALL) {
+                    for(s=-1; s < (fixnum_t)i; s++)
+                        Stack[bp+s] = Stack[SP-i+s];
+                    SP = bp+i;
+                    nargs = i;
+                    goto apply_cl_top;
                 }
                 else {
-                    v = _applyn(i);
+                    v = apply_cl(i);
                 }
             }
+            else if (iscons(func)) {
+                v = _applyn(i);
+            }
             else {
                 type_error("apply", "function", func);
             }
@@ -2140,19 +2137,20 @@
                 PUSH(Stack[bp]); // env has already been captured; share
             }
             if (op == OP_CLOSURE) {
-              c = (cons_t*)ptr(v=cons_reserve(3));
-              e = cdr_(Stack[SP-2]);  // closure to copy
-              //if (!iscons(e)) goto notpair;
-              c->car = COMPILEDLAMBDA;
-              c->cdr = tagptr(c+1, TAG_CONS); c++;
-              c->car = car_(e);      //argsyms
-              c->cdr = tagptr(c+1, TAG_CONS); c++;
-              e = cdr_(e);
-              //if (!iscons(e=cdr_(e))) goto notpair;
-              c->car = car_(e);      //body
-              c->cdr = Stack[SP-1];  //env
-              POPN(1);
-              Stack[SP-1] = v;
+                pv = alloc_words(6);
+                x = Stack[SP-2];  // closure to copy
+                assert(isfunction(x));
+                pv[0] = ((value_t*)ptr(x))[0];
+                assert(pv[0] == functiontype);
+                pv[1] = (value_t)&pv[3];
+                pv[2] = ((value_t*)ptr(x))[2];
+                pv[3] = ((value_t*)ptr(x))[3];
+                assert(isstring(pv[3]));
+                pv[4] = ((value_t*)ptr(x))[4];
+                assert(isvector(pv[4]));
+                pv[5] = Stack[SP-1];  // env
+                POPN(1);
+                Stack[SP-1] = tagptr(pv, TAG_CVALUE);
             }
             break;
 
@@ -2180,6 +2178,80 @@
     }
 }
 
+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 @@
     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 @@
 #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));
@@ -2272,6 +2342,11 @@
 
     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();
 }
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -93,6 +93,8 @@
                       (((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))
@@ -222,6 +224,12 @@
     fltype_t *type;
     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
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -551,8 +551,10 @@
         }
         PUSH(NIL);
         read_list(&Stack[SP-1], UNBOUND);
-        v = POP();
-        return apply(toplevel_eval(sym), v);
+        v = symbol_value(sym);
+        if (v == UNBOUND)
+            raise(list2(UnboundError, sym));
+        return apply(v, POP());
     case TOK_OPENB:
         return read_vector(label, TOK_CLOSEB);
     case TOK_SHARPOPEN:
--- a/femtolisp/system.lsp
+++ b/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 (car x) 'compiled-lambda)))))
+      (eq (typeof x) 'function)
+      (and (pair? x) (eq (car x) 'lambda))))
 (define procedure? function?)
 
 (define (caar x) (car (car x)))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1018,7 +1018,7 @@
 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