shithub: femtolisp

Download patch

ref: 77e37368c9f126a14cf9d09fd61d0df7cee15af3
parent: a7a31cf53a65f84f6edab3e2f067ef6423cb7a27
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Tue May 12 21:13:40 EDT 2009

fixing trace and untrace
replacing function->vector with function:code, function:vals, and
  function:env


--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -446,56 +446,55 @@
       (begin (disassemble f 0)
 	     (newline)
 	     (return #t)))
-  (let ((fvec (function->vector f))
-	(lev (car lev?)))
-    (let ((code (aref fvec 0))
-	  (vals (aref fvec 1)))
-      (define (print-val v)
-	(if (and (function? v) (not (builtin? v)))
-	    (begin (princ "\n")
-		   (disassemble v (+ lev 1)))
-	    (print v)))
-      (let ((i 0)
-	    (N (length code)))
-	(while (< i N)
-	       ; find key whose value matches the current byte
-	       (let ((inst (table.foldl (lambda (k v z)
-					  (or z (and (eq? v (aref code i))
-						     k)))
-					#f Instructions)))
-		 (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 :apply :tapply)
-		    (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))))))))
+  (let ((lev (car lev?))
+	(code (function:code f))
+	(vals (function:vals f)))
+    (define (print-val v)
+      (if (and (function? v) (not (builtin? v)))
+	  (begin (princ "\n")
+		 (disassemble v (+ lev 1)))
+	  (print v)))
+    (let ((i 0)
+	  (N (length code)))
+      (while (< i N)
+	     ; find key whose value matches the current byte
+	     (let ((inst (table.foldl (lambda (k v z)
+					(or z (and (eq? v (aref code i))
+						   k)))
+				      #f Instructions)))
+	       (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 :apply :tapply)
+		  (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)))))))
 
 #t
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -5,11 +5,13 @@
 vector->list
 #function("n1b0d1e031^p43;" [#function("q`e0b0lr2e1;" [#function("n1f10f00e0uZf01Kj01;" [])]) length])
 untrace
-#function("n1b0d1e031p42;" [#function("qe0Mb0<6T0d1f00d2d3d4d5e03131313142;];" [trace-lambda set-top-level-value! cadr caar last-pair caddr]) top-level-value])
+#function("n1b0d1e031p42;" [#function("qd0e0316K0d1f00d2e031a2Z42;];" [traced? set-top-level-value! function:vals]) top-level-value])
 transpose
 #function("n1d0d1e0s3;" [mapcar list])
+traced?
+#function("n1d0e031d0f0031>;" [function:code] #0=[#function("o0d0b1e0K312b2e0s2;" [println x #.apply] #0#) ()])
 trace
-#function("n1b0d1e031p322b2;" [#function("qb0d1e031p42;" [#function("qb0d1e031p42;" [#function("qf10Mb0<@6\x920d1f20b0f00d2b3L1b4b5L2L1b6b7f20L2L2L1d8d9b:le03231b4b;L2L1d2b7f10L2L1d8e03132L136L342;];" [trace-lambda set-top-level-value! nconc begin princ "(" print quote copy-list map #function("n1b0b1b2L2b3e0L2L3;" [begin princ " " print]) ")\n"]) to-proper]) cadr]) top-level-value ok])
+#function("n1b0d1e031p322b2;" [#function("qb0d130p42;" [#function("qd0f0031@6p0d1f10d2b3e0b4b5b6b7f10L2e0L3L2b8b7f00L2e0L3L3L33142;];" [traced? set-top-level-value! eval lambda begin println cons quote apply]) gensym]) top-level-value ok])
 to-proper
 #function("n1e0A6;0e0;e0?6F0e0L1;e0Md0e0N31K;" [to-proper])
 table.values
@@ -201,7 +203,7 @@
 display
 #function("n1d0e0312\\;" [princ])
 disassemble
-#function("o1e1A6J0d0e0_322d1302\\;5K0]2b2d3e031e1Mp43;" [disassemble newline #function("qb0e0_Ze0`Zp43;" [#function("qb0]p42;" [#function("qb0li02b1_d2f0031p43;" [#function("n1e0J16>02e0G@6T0d0b1312d2e0f21`t42;d3e041;" [princ "\n" disassemble print]) #function("q]e0e1W6M02b0d1b2l]d333p32520;" [#function("qd0f00_326C0d1305D0]2_f31`ub2lr2d3d4f0031b5d6d7e031`32b8342f00`tj002b9e0p42;" [> newline #function("n1d0b141;" [princ "\t"]) princ hex5 ":  " string.tail string "\t" #function("qd0e0b1326Z0f20f31d2f30f1032Z312f10a4tj10;d0e0b3326\x7f0f20f31f30f10ZZ312f10`tj10;d0e0b4326\xa30d5d6f30f10Z31312f10`tj10;d0e0b7326\xe20d5d6f30f10Z31b8322f10`tj102d5d6f30f10Z31312f10`tj10;d0e0b9326\x0c0d5b:d;d<f30f103231322f10a2tj10;d0e0b=32661d5b:d;d2f30f103231322f10a4tj10;];" [memv (:loadv.l :loadg.l :setg.l) ref-uint32-LE (:loadv :loadg :setg) (:loada :seta :call :tcall :list :+ :- :* :/ :vector :argc :vargc :loadi8 :apply :tapply) princ number->string (:loadc :setc) " " (:jmp :brf :brt) "@" hex5 ref-uint16-LE (:jmp.l :brf.l :brt.l)])]) table.foldl #function("n3e217J02e1f20f00Z<16J02e0;" []) Instructions]) length])])]) function->vector])
+#function("o1e1A6J0d0e0_322d1302\\;5K0]2b2e1Md3e031d4e031p44;" [disassemble newline #function("qb0]p42;" [#function("qb0li02b1_d2f0131p43;" [#function("n1e0J16>02e0G@6T0d0b1312d2e0f10`t42;d3e041;" [princ "\n" disassemble print]) #function("q]e0e1W6M02b0d1b2l]d333p32520;" [#function("qd0f00_326C0d1305D0]2_f20`ub2lr2d3d4f0031b5d6d7e031`32b8342f00`tj002b9e0p42;" [> newline #function("n1d0b141;" [princ "\t"]) princ hex5 ":  " string.tail string "\t" #function("qd0e0b1326Z0f20f32d2f31f1032Z312f10a4tj10;d0e0b3326\x7f0f20f32f31f10ZZ312f10`tj10;d0e0b4326\xa30d5d6f31f10Z31312f10`tj10;d0e0b7326\xe20d5d6f31f10Z31b8322f10`tj102d5d6f31f10Z31312f10`tj10;d0e0b9326\x0c0d5b:d;d<f31f103231322f10a2tj10;d0e0b=32661d5b:d;d2f31f103231322f10a4tj10;];" [memv (:loadv.l :loadg.l :setg.l) ref-uint32-LE (:loadv :loadg :setg) (:loada :seta :call :tcall :list :+ :- :* :/ :vector :argc :vargc :loadi8 :apply :tapply) princ number->string (:loadc :setc) " " (:jmp :brf :brt) "@" hex5 ref-uint16-LE (:jmp.l :brf.l :brt.l)])]) table.foldl #function("n3e217J02e1f21f00Z<16J02e0;" []) Instructions]) length])]) function:code function:vals])
 delete-duplicates
 #function("n1e0?6;0e0;b0e0Me0Np43;" [#function("qd0e0e1326C0d1e141;e0d1e131K;" [member delete-duplicates])])
 count
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -277,10 +277,10 @@
 // gensym names available at a time, mostly for compare()
 static char gsname[2][16];
 static int gsnameno=0;
-value_t gensym(value_t *args, uint32_t nargs)
+value_t fl_gensym(value_t *args, uint32_t nargs)
 {
+    argcount("gensym", nargs, 0);
     (void)args;
-    (void)nargs;
     gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
     gs->id = _gensym_ctr++;
     gs->binding = UNBOUND;
@@ -289,11 +289,6 @@
     return tagptr(gs, TAG_SYM);
 }
 
-value_t fl_gensym()
-{
-    return gensym(NULL, 0);
-}
-
 char *symbol_name(value_t v)
 {
     if (ismanaged(v)) {
@@ -776,23 +771,21 @@
   - check arg counts
   - allocate vararg array
   - push closed env, set up new environment
-
-  ** need 'copyenv' instruction that moves env to heap, installs
-     heap version as the current env, and pushes the result vector.
-     this can be used to implement the copy-closure op in terms of
-     other ops. and it can be the first instruction in lambdas in
-     head position (let optimization).
 */
 static value_t apply_cl(uint32_t nargs)
 {
-    uint32_t i, n, ip, bp, envsz, captured, op;
-    fixnum_t s, lo, hi;
-    int64_t accum;
+    // frame variables
+    uint32_t i, n, ip, bp, captured;
+    fixnum_t s, hi;
     uint8_t *code;
-    value_t func, v, x, e;
-    value_t *lenv, *pv;
+
+    // temporary variables (not necessary to preserve across calls)
+    uint32_t op, envsz;
+    int64_t accum;
     symbol_t *sym;
     cons_t *c;
+    value_t func, v, x, e;
+    value_t *lenv, *pv;
 
  apply_cl_top:
     captured = 0;
@@ -1254,13 +1247,13 @@
             Stack[SP-1] = v;
             goto next_op;
         case OP_FOR:
-            lo = tofixnum(Stack[SP-3], "for");
+            s  = tofixnum(Stack[SP-3], "for");
             hi = tofixnum(Stack[SP-2], "for");
             //f = Stack[SP-1];
             v = FL_F;
             SP += 2;
             i = SP;
-            for(s=lo; s <= hi; s++) {
+            for(; s <= hi; s++) {
                 Stack[SP-2] = Stack[SP-3];
                 Stack[SP-1] = fixnum(s);
                 v = apply_cl(1);
@@ -1451,24 +1444,34 @@
     return fv;
 }
 
-static value_t fl_function2vector(value_t *args, uint32_t nargs)
+static value_t fl_function_code(value_t *args, uint32_t nargs)
 {
-    argcount("function->vector", nargs, 1);
+    argcount("function:code", nargs, 1);
     value_t v = args[0];
-    if (!isclosure(v))
-        type_error("function->vector", "function", v);
-    value_t vec = alloc_vector(3, 0);
-    function_t *fn = (function_t*)ptr(args[0]);
-    vector_elt(vec,0) = fn->bcode;
-    vector_elt(vec,1) = fn->vals;
-    vector_elt(vec,2) = fn->env;
-    return vec;
+    if (!isclosure(v)) type_error("function:code", "function", v);
+    return fn_bcode(v);
 }
+static value_t fl_function_vals(value_t *args, uint32_t nargs)
+{
+    argcount("function:vals", nargs, 1);
+    value_t v = args[0];
+    if (!isclosure(v)) type_error("function:vals", "function", v);
+    return fn_vals(v);
+}
+static value_t fl_function_env(value_t *args, uint32_t nargs)
+{
+    argcount("function:env", nargs, 1);
+    value_t v = args[0];
+    if (!isclosure(v)) type_error("function:env", "function", v);
+    return fn_env(v);
+}
 
 static builtinspec_t core_builtin_info[] = {
     { "function", fl_function },
-    { "function->vector", fl_function2vector },
-    { "gensym", gensym },
+    { "function:code", fl_function_code },
+    { "function:vals", fl_function_vals },
+    { "function:env", fl_function_env },
+    { "gensym", fl_gensym },
     { "hash", fl_hash },
     { NULL, NULL }
 };
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -138,7 +138,6 @@
 value_t list2(value_t a, value_t b);
 value_t listn(size_t n, ...);
 value_t symbol(char *str);
-value_t fl_gensym();
 char *symbol_name(value_t v);
 value_t alloc_vector(size_t n, int init);
 size_t llength(value_t v);
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -600,7 +600,7 @@
     case TOK_GENSYM:
         pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
         if (*pv == (value_t)HT_NOTFOUND)
-            *pv = gensym(NULL, 0);
+            *pv = fl_gensym(NULL, 0);
         return *pv;
     case TOK_DOUBLEQUOTE:
         return read_string();
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -458,29 +458,29 @@
 
 (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
 
+(letrec ((sample-traced-lambda (lambda args (begin (println (cons 'x args))
+						   (apply #.apply args)))))
+  (set! traced?
+	(lambda (f)
+	  (equal? (function:code f)
+		  (function:code sample-traced-lambda)))))
+
 (define (trace sym)
-  (let* ((lam  (top-level-value sym))
-	 (args (cadr lam))
-	 (al   (to-proper args)))
-    (if (not (eq? (car lam) 'trace-lambda))
+  (let* ((func (top-level-value sym))
+	 (args (gensym)))
+    (if (not (traced? func))
 	(set-top-level-value! sym
-	     `(trace-lambda ,args
-	        (begin
-		  (princ "(")
-		  (print ',sym)
-		  ,@(map (lambda (a)
-			   `(begin (princ " ")
-				   (print ,a)))
-			 al)
-		  (princ ")\n")
-		  (',lam ,@al))))))
+			      (eval
+			       `(lambda ,args
+				  (begin (println (cons ',sym ,args))
+					 (apply ',func ,args)))))))
   'ok)
 
 (define (untrace sym)
-  (let ((lam  (top-level-value sym)))
-    (if (eq? (car lam) 'trace-lambda)
+  (let ((func (top-level-value sym)))
+    (if (traced? func)
 	(set-top-level-value! sym
-	     (cadr (caar (last-pair (caddr lam))))))))
+			      (aref (function:vals func) 2)))))
 
 (define-macro (time expr)
   (let ((t0 (gensym)))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -1033,7 +1033,7 @@
 - let eversion
 * have macroexpand use its own global syntax table
 * be able to create/load an image file
-- fix trace and untrace
+* fix trace and untrace
 - opcodes CAAR, CADR, CDAR, CDDR, LOADA0, LOADA1, LOADC00, LOADC01, LOADC10
 - EQTO N, compare directly to stored datum N
 - peephole opt