summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-10-15 22:30:47 +0200
committerAndy Wingo <wingo@pobox.com>2008-10-15 22:30:47 +0200
commit8f64368ee5e2923f38867da2d367755445e931d4 (patch)
treed3fbfa54901fd781492aa06740a83bd20f1507a3
parent02b1883e5661eb1a9bfb196e060a22c2c2cadc88 (diff)
downloadguile-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.scm20
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