summaryrefslogtreecommitdiff
path: root/module/system/vm/disassembler.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-08 15:58:27 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-08 15:58:27 +0100
commit850e80dacc6bb7a4e91fcd4e665fe1f5518556c8 (patch)
treed23ec02de07872cba25bf35c8ad545191ba74192 /module/system/vm/disassembler.scm
parent5af36584d86791dd7267c27fc05384a5453d2c24 (diff)
downloadguile-850e80dacc6bb7a4e91fcd4e665fe1f5518556c8.tar.gz
Add fold-program-code to (system vm disassembler)
* module/system/vm/disassembler.scm (fold-code-range): New helper. (fold-program-code): New interface.
Diffstat (limited to 'module/system/vm/disassembler.scm')
-rw-r--r--module/system/vm/disassembler.scm66
1 files changed, 66 insertions, 0 deletions
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 1683b685d..ccdedf808 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -32,6 +32,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-4)
#:export (disassemble-program
+ fold-program-code
disassemble-image
disassemble-file))
@@ -362,6 +363,71 @@ address of that offset."
(format port "Debugging information unavailable.~%")))
(values))
+(define (fold-code-range proc seed bv start end context raw?)
+ (define (cook code offset)
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+ (match code
+ (((or 'make-short-immediate 'make-long-immediate) dst imm)
+ `(,(car code) ,dst ,(unpack-scm imm)))
+ (('make-long-long-immediate dst high low)
+ `(make-long-long-immediate ,dst
+ ,(unpack-scm (logior (ash high 32) low))))
+ (('make-closure dst target nfree)
+ `(make-closure ,dst
+ ,(u32-offset->addr (+ offset target) context)
+ ,nfree))
+ (('make-non-immediate dst target)
+ `(make-non-immediate ,dst ,(reference-scm target)))
+ (('builtin-ref dst idx)
+ `(builtin-ref ,dst ,(builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) dst target)
+ `(,(car code) ,dst ,(dereference-scm target)))
+ (('toplevel-box dst var-offset mod-offset sym-offset bound?)
+ `(toplevel-box ,dst
+ ,(dereference-scm var-offset)
+ ,(dereference-scm mod-offset)
+ ,(dereference-scm sym-offset)
+ ,bound?))
+ (('module-box dst var-offset mod-name-offset sym-offset bound?)
+ (let ((mod-name (reference-scm mod-name-offset)))
+ `(module-box ,dst
+ ,(dereference-scm var-offset)
+ ,(car mod-name)
+ ,(cdr mod-name)
+ ,(dereference-scm sym-offset)
+ ,bound?)))
+ (_ code)))
+ (let lp ((offset start) (seed seed))
+ (cond
+ ((< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (lp (+ offset len)
+ (proc (if raw? elt (cook elt offset))
+ seed)))))
+ (else seed))))
+
+(define* (fold-program-code proc seed program-or-addr #:key raw?)
+ (cond
+ ((find-program-debug-info (if (rtl-program? program-or-addr)
+ (rtl-program-code program-or-addr)
+ program-or-addr))
+ => (lambda (pdi)
+ (fold-code-range proc seed
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi)
+ raw?)))
+ (else seed)))
+
(define* (disassemble-image bv #:optional (port (current-output-port)))
(let* ((ctx (debug-context-from-image bv))
(base (debug-context-text-base ctx)))