fixing trace and untrace
replacing function->vector with function:code, function:vals, and function:env
This commit is contained in:
JeffBezanson
parent
a7a31cf53a
commit
77e37368c9
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;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
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
};
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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();
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue