From 77e37368c9f126a14cf9d09fd61d0df7cee15af3 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Wed, 13 May 2009 01:13:40 +0000 Subject: [PATCH] fixing trace and untrace replacing function->vector with function:code, function:vals, and function:env --- femtolisp/compiler.lsp | 101 ++++++++++++++++++++--------------------- femtolisp/flisp.boot | 8 ++-- femtolisp/flisp.c | 67 ++++++++++++++------------- femtolisp/flisp.h | 1 - femtolisp/read.c | 2 +- femtolisp/system.lsp | 34 +++++++------- femtolisp/todo | 2 +- 7 files changed, 109 insertions(+), 106 deletions(-) diff --git a/femtolisp/compiler.lsp b/femtolisp/compiler.lsp index e58d4d1..4772f40 100644 --- 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 diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index ce7ced5..7607207 100644 --- a/femtolisp/flisp.boot +++ b/femtolisp/flisp.boot @@ -5,11 +5,13 @@ vector.map 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 @@ emit 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;dstring (: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;dstring (: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 diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index b128da1..adb7ff8 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -277,10 +277,10 @@ static uint32_t _gensym_ctr=0; // 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 @@ value_t gensym(value_t *args, uint32_t nargs) 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 @@ static value_t do_trycatch() - 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 @@ static value_t apply_cl(uint32_t nargs) 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 @@ static value_t fl_function(value_t *args, uint32_t nargs) 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 } }; diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 70ffd18..86eb366 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -138,7 +138,6 @@ value_t fl_cons(value_t a, value_t b); 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); diff --git a/femtolisp/read.c b/femtolisp/read.c index f5acb4a..8262ad8 100644 --- a/femtolisp/read.c +++ b/femtolisp/read.c @@ -600,7 +600,7 @@ static value_t do_read_sexpr(value_t label) 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(); diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 95b8003..0fb25c1 100644 --- 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))) diff --git a/femtolisp/todo b/femtolisp/todo index eb044a7..7c400b9 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -1033,7 +1033,7 @@ new evaluator todo: - 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