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