diff options
author | Andy Wingo <wingo@pobox.com> | 2008-10-15 22:30:47 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-10-15 22:30:47 +0200 |
commit | 8f64368ee5e2923f38867da2d367755445e931d4 (patch) | |
tree | d3fbfa54901fd781492aa06740a83bd20f1507a3 | |
parent | 02b1883e5661eb1a9bfb196e060a22c2c2cadc88 (diff) | |
download | guile-8f64368ee5e2923f38867da2d367755445e931d4.tar.gz |
fix disasm bugs, add some more instruction annotations
* module/system/vm/disasm.scm (disassemble-program): Fix misunderstanding
of nlocs: the *actual* number of locals is nlocs + nargs, even if the
arg is heap-allocated -- because our calling convention always puts the
initial val on the stack. Also: don't disassemble the objects, they are
now woven into the text.
(code-annotation): Fix external-{ref,set} handling to allow for
referencing externals from enclosed stack frames. Really this should be
statically determined, though. Add late-variable-{ref,set} handling.
-rw-r--r-- | module/system/vm/disasm.scm | 20 |
1 files changed, 14 insertions, 6 deletions
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 8ba36675c..cda471951 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -51,7 +51,9 @@ (exts (program-external prog)) (binds (program-bindings prog)) (blocs (and binds - (filter (lambda (x) (not (binding:extp x))) binds))) + (append (list-head binds nargs) + (filter (lambda (x) (not (binding:extp x))) + (list-tail binds nargs))))) (bexts (and binds (filter binding:extp binds))) (srcs (program-sources prog))) @@ -61,8 +63,6 @@ nargs nrest nlocs nexts) (format #t "Bytecode:\n\n") (disassemble-bytecode bytes objs nargs blocs bexts srcs) - (if (> (vector-length objs) 0) - (disassemble-objects objs)) (if (pair? exts) (disassemble-externals exts)) (if meta @@ -151,9 +151,17 @@ (binding:name b) (< (binding:index b) nargs))))) ((external-ref external-set) (and bexts - (let ((b (list-ref bexts (car args)))) - (list "`~a'~@[ (arg)~]" - (binding:name b) (< (binding:index b) nargs))))) + (if (< (car args) (length bexts)) + (let ((b (list-ref bexts (car args)))) + (list "`~a'~@[ (arg)~]" + (binding:name b) (< (binding:index b) nargs))) + (list "(closure variable)")))) + ((late-variable-ref late-variable-set) + (and objs + (let ((v (vector-ref objs (car args)))) + (if (and (variable? v) (variable-bound? v)) + (list "~s" (variable-ref v)) + (list "`~s'" v))))) ((mv-call) (list "MV -> ~A" (+ end-addr (apply make-int16 args)))) (else |