lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixing trace and untrace 

replacing function->vector with function:code, function:vals, and
  function:env
This commit is contained in:
JeffBezanson 2009-05-13 01:13:40 +00:00
parent a7a31cf53a
commit 77e37368c9
7 changed files with 109 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
femtolisp/compiler.lsp
View File

@ -446,56 +446,55 @@
(begin (disassemble f 0) (begin (disassemble f 0)
(newline) (newline)
(return #t))) (return #t)))
(let ((fvec (function->vector f)) (let ((lev (car lev?))
(lev (car lev?))) (code (function:code f))
(let ((code (aref fvec 0)) (vals (function:vals f)))
(vals (aref fvec 1))) (define (print-val v)
(define (print-val v) (if (and (function? v) (not (builtin? v)))
(if (and (function? v) (not (builtin? v))) (begin (princ "\n")
(begin (princ "\n") (disassemble v (+ lev 1)))
(disassemble v (+ lev 1))) (print v)))
(print v))) (let ((i 0)
(let ((i 0) (N (length code)))
(N (length code))) (while (< i N)
(while (< i N) ; find key whose value matches the current byte
; find key whose value matches the current byte (let ((inst (table.foldl (lambda (k v z)
(let ((inst (table.foldl (lambda (k v z) (or z (and (eq? v (aref code i))
(or z (and (eq? v (aref code i)) k)))
k))) #f Instructions)))
#f Instructions))) (if (> i 0) (newline))
(if (> i 0) (newline)) (dotimes (xx lev) (princ "\t"))
(dotimes (xx lev) (princ "\t")) (princ (hex5 i) ": "
(princ (hex5 i) ": " (string.tail (string inst) 1) "\t")
(string.tail (string inst) 1) "\t") (set! i (+ i 1))
(set! i (+ i 1)) (case inst
(case inst ((:loadv.l :loadg.l :setg.l)
((:loadv.l :loadg.l :setg.l) (print-val (aref vals (ref-uint32-LE code i)))
(print-val (aref vals (ref-uint32-LE code i))) (set! i (+ i 4)))
(set! i (+ i 4)))
((:loadv :loadg :setg) ((:loadv :loadg :setg)
(print-val (aref vals (aref code i))) (print-val (aref vals (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loada :seta :call :tcall :list :+ :- :* :/ :vector ((:loada :seta :call :tcall :list :+ :- :* :/ :vector
:argc :vargc :loadi8 :apply :tapply) :argc :vargc :loadi8 :apply :tapply)
(princ (number->string (aref code i))) (princ (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:loadc :setc) ((:loadc :setc)
(princ (number->string (aref code i)) " ") (princ (number->string (aref code i)) " ")
(set! i (+ i 1)) (set! i (+ i 1))
(princ (number->string (aref code i))) (princ (number->string (aref code i)))
(set! i (+ i 1))) (set! i (+ i 1)))
((:jmp :brf :brt) ((:jmp :brf :brt)
(princ "@" (hex5 (ref-uint16-LE code i))) (princ "@" (hex5 (ref-uint16-LE code i)))
(set! i (+ i 2))) (set! i (+ i 2)))
((:jmp.l :brf.l :brt.l) ((:jmp.l :brf.l :brt.l)
(princ "@" (hex5 (ref-uint32-LE code i))) (princ "@" (hex5 (ref-uint32-LE code i)))
(set! i (+ i 4))) (set! i (+ i 4)))
(else #f)))))))) (else #f)))))))
#t #t

8
femtolisp/flisp.boot
View File

@ -5,11 +5,13 @@ vector.map
vector->list vector->list
#function("n1b0d1e031^p43;" [#function("q`e0b0lr2e1;" [#function("n1f10f00e0uZf01Kj01;" [])]) length]) #function("n1b0d1e031^p43;" [#function("q`e0b0lr2e1;" [#function("n1f10f00e0uZf01Kj01;" [])]) length])
untrace 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 transpose
#function("n1d0d1e0s3;" [mapcar list]) #function("n1d0d1e0s3;" [mapcar list])
traced?
#function("n1d0e031d0f0031>;" [function:code] #0=[#function("o0d0b1e0K312b2e0s2;" [println x #.apply] #0#) ()])
trace 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 to-proper
#function("n1e0A6;0e0;e0?6F0e0L1;e0Md0e0N31K;" [to-proper]) #function("n1e0A6;0e0;e0?6F0e0L1;e0Md0e0N31K;" [to-proper])
table.values table.values
@ -201,7 +203,7 @@ emit
display display
#function("n1d0e0312\\;" [princ]) #function("n1d0e0312\\;" [princ])
disassemble 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 delete-duplicates
#function("n1e0?6;0e0;b0e0Me0Np43;" [#function("qd0e0e1326C0d1e141;e0d1e131K;" [member delete-duplicates])]) #function("n1e0?6;0e0;b0e0Me0Np43;" [#function("qd0e0e1326C0d1e141;e0d1e131K;" [member delete-duplicates])])
count count

67
femtolisp/flisp.c
View File

@ -277,10 +277,10 @@ static uint32_t _gensym_ctr=0;
// gensym names available at a time, mostly for compare() // gensym names available at a time, mostly for compare()
static char gsname[2][16]; static char gsname[2][16];
static int gsnameno=0; 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)args;
(void)nargs;
gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*)); gensym_t *gs = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*));
gs->id = _gensym_ctr++; gs->id = _gensym_ctr++;
gs->binding = UNBOUND; gs->binding = UNBOUND;
@ -289,11 +289,6 @@ value_t gensym(value_t *args, uint32_t nargs)
return tagptr(gs, TAG_SYM); return tagptr(gs, TAG_SYM);
} }
value_t fl_gensym()
{
return gensym(NULL, 0);
}
char *symbol_name(value_t v) char *symbol_name(value_t v)
{ {
if (ismanaged(v)) { if (ismanaged(v)) {
@ -776,23 +771,21 @@ static value_t do_trycatch()
- check arg counts - check arg counts
- allocate vararg array - allocate vararg array
- push closed env, set up new environment - 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) static value_t apply_cl(uint32_t nargs)
{ {
uint32_t i, n, ip, bp, envsz, captured, op; // frame variables
fixnum_t s, lo, hi; uint32_t i, n, ip, bp, captured;
int64_t accum; fixnum_t s, hi;
uint8_t *code; 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; symbol_t *sym;
cons_t *c; cons_t *c;
value_t func, v, x, e;
value_t *lenv, *pv;
apply_cl_top: apply_cl_top:
captured = 0; captured = 0;
@ -1254,13 +1247,13 @@ static value_t apply_cl(uint32_t nargs)
Stack[SP-1] = v; Stack[SP-1] = v;
goto next_op; goto next_op;
case OP_FOR: case OP_FOR:
lo = tofixnum(Stack[SP-3], "for"); s = tofixnum(Stack[SP-3], "for");
hi = tofixnum(Stack[SP-2], "for"); hi = tofixnum(Stack[SP-2], "for");
//f = Stack[SP-1]; //f = Stack[SP-1];
v = FL_F; v = FL_F;
SP += 2; SP += 2;
i = SP; i = SP;
for(s=lo; s <= hi; s++) { for(; s <= hi; s++) {
Stack[SP-2] = Stack[SP-3]; Stack[SP-2] = Stack[SP-3];
Stack[SP-1] = fixnum(s); Stack[SP-1] = fixnum(s);
v = apply_cl(1); v = apply_cl(1);
@ -1451,24 +1444,34 @@ static value_t fl_function(value_t *args, uint32_t nargs)
return fv; 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]; value_t v = args[0];
if (!isclosure(v)) if (!isclosure(v)) type_error("function:code", "function", v);
type_error("function->vector", "function", v); return fn_bcode(v);
value_t vec = alloc_vector(3, 0); }
function_t *fn = (function_t*)ptr(args[0]); static value_t fl_function_vals(value_t *args, uint32_t nargs)
vector_elt(vec,0) = fn->bcode; {
vector_elt(vec,1) = fn->vals; argcount("function:vals", nargs, 1);
vector_elt(vec,2) = fn->env; value_t v = args[0];
return vec; 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[] = { static builtinspec_t core_builtin_info[] = {
{ "function", fl_function }, { "function", fl_function },
{ "function->vector", fl_function2vector }, { "function:code", fl_function_code },
{ "gensym", gensym }, { "function:vals", fl_function_vals },
{ "function:env", fl_function_env },
{ "gensym", fl_gensym },
{ "hash", fl_hash }, { "hash", fl_hash },
{ NULL, NULL } { NULL, NULL }
}; };

1
femtolisp/flisp.h
View File

@ -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 list2(value_t a, value_t b);
value_t listn(size_t n, ...); value_t listn(size_t n, ...);
value_t symbol(char *str); value_t symbol(char *str);
value_t fl_gensym();
char *symbol_name(value_t v); char *symbol_name(value_t v);
value_t alloc_vector(size_t n, int init); value_t alloc_vector(size_t n, int init);
size_t llength(value_t v); size_t llength(value_t v);

2
femtolisp/read.c
View File

@ -600,7 +600,7 @@ static value_t do_read_sexpr(value_t label)
case TOK_GENSYM: case TOK_GENSYM:
pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval); pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
if (*pv == (value_t)HT_NOTFOUND) if (*pv == (value_t)HT_NOTFOUND)
*pv = gensym(NULL, 0); *pv = fl_gensym(NULL, 0);
return *pv; return *pv;
case TOK_DOUBLEQUOTE: case TOK_DOUBLEQUOTE:
return read_string(); return read_string();

34
femtolisp/system.lsp
View File

@ -458,29 +458,29 @@
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (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) (define (trace sym)
(let* ((lam (top-level-value sym)) (let* ((func (top-level-value sym))
(args (cadr lam)) (args (gensym)))
(al (to-proper args))) (if (not (traced? func))
(if (not (eq? (car lam) 'trace-lambda))
(set-top-level-value! sym (set-top-level-value! sym
`(trace-lambda ,args (eval
(begin `(lambda ,args
(princ "(") (begin (println (cons ',sym ,args))
(print ',sym) (apply ',func ,args)))))))
,@(map (lambda (a)
`(begin (princ " ")
(print ,a)))
al)
(princ ")\n")
(',lam ,@al))))))
'ok) 'ok)
(define (untrace sym) (define (untrace sym)
(let ((lam (top-level-value sym))) (let ((func (top-level-value sym)))
(if (eq? (car lam) 'trace-lambda) (if (traced? func)
(set-top-level-value! sym (set-top-level-value! sym
(cadr (caar (last-pair (caddr lam)))))))) (aref (function:vals func) 2)))))
(define-macro (time expr) (define-macro (time expr)
(let ((t0 (gensym))) (let ((t0 (gensym)))

2
femtolisp/todo
View File

@ -1033,7 +1033,7 @@ new evaluator todo:
- let eversion - let eversion
* have macroexpand use its own global syntax table * have macroexpand use its own global syntax table
* be able to create/load an image file * 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 - opcodes CAAR, CADR, CDAR, CDDR, LOADA0, LOADA1, LOADC00, LOADC01, LOADC10
- EQTO N, compare directly to stored datum N - EQTO N, compare directly to stored datum N
- peephole opt - peephole opt