mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

fix disasm bugs, add some more instruction annotations

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2008-10-15 22:30:47 +02:00
parent 02b1883e56
commit 8f64368ee5
1 changed files with 14 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

20
module/system/vm/disasm.scm
View file

@ -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