1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00

simplify disassembly annotations a bit

* module/system/vm/disasm.scm (original-value): Simplify a bit to
  normally dispatch on the instruction, only trying code->object at the
  end.
This commit is contained in:
Andy Wingo 2008-10-11 18:55:44 +02:00
parent 972c33e592
commit 95b6ad34c3

View file

@ -157,31 +157,23 @@
(newline))))
(define (original-value addr code objs)
(define (branch-code? code)
(string-match "^br" (symbol->string (car code))))
(define (list-or-vector? code)
(case (car code)
((list vector) #t)
(else #f)))
(let ((code (code-unpack code)))
(cond ((list-or-vector? code)
(let ((len (+ (* (cadr code) 256) (caddr code))))
(format #f "~a element~a" len (if (> len 1) "s" ""))))
((code->object code) => object->string)
((branch-code? code)
(let ((offset (+ (* (cadr code) 256) (caddr code))))
(format #f "-> ~A" (+ addr offset 3))))
(else
(let ((inst (car code)) (args (cdr code)))
(case inst
((make-false) "#f")
((object-ref)
(if objs (object->string (vector-ref objs (car args))) #f))
((mv-call)
(let ((offset (+ (* (caddr code) 256) (cadddr code))))
(format #f "MV -> ~A" (+ addr offset 4))))
(else #f)))))))
(let* ((code (code-unpack code))
(inst (car code))
(args (cdr code)))
(case inst
((list vector)
(let ((len (+ (* (cadr code) 256) (caddr code))))
(format #f "~a element~a" len (if (> len 1) "s" ""))))
((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
(let ((offset (+ (* (car args) 256) (cadr args))))
(format #f "-> ~A" (+ addr offset 3))))
((object-ref)
(if objs (object->string (vector-ref objs (car args))) #f))
((mv-call)
(let ((offset (+ (* (caddr code) 256) (cadddr code))))
(format #f "MV -> ~A" (+ addr offset 4))))
(else
(and=> (code->object code) object->string)))))
(define (list->info list)
(object->string list))