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

,x disassembles nested programs too

Browse source 
* module/system/vm/disassembler.scm (code-annotation):
  (disassemble-buffer, disassemble-addr, disassemble-program): Arrange
  to disassemble nested procedures.
  (disassemble-image): Adapt.
This commit is contained in:
Andy Wingo 2013-11-29 17:52:11 +01:00
parent f5729276a9
commit 321c32dc9d
1 changed files with 38 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

59
module/system/vm/disassembler.scm
View file

@ -199,7 +199,7 @@
address of that offset." address of that offset."
(+ (debug-context-base context) (* offset 4))) (+ (debug-context-base context) (* offset 4)))
(define (code-annotation code len offset start labels context) (define (code-annotation code len offset start labels context push-addr!)
;; FIXME: Print names for register loads and stores that correspond to ;; FIXME: Print names for register loads and stores that correspond to
;; access to named locals. ;; access to named locals.
(define (reference-scm target) (define (reference-scm target)
@ -244,19 +244,22 @@ address of that offset."
(list "~a arg~:p" nargs)) (list "~a arg~:p" nargs))
(('make-closure dst target nfree) (('make-closure dst target nfree)
(let* ((addr (u32-offset->addr (+ offset target) context)) (let* ((addr (u32-offset->addr (+ offset target) context))
(pdi (find-program-debug-info addr context))) (pdi (find-program-debug-info addr context))
;; FIXME: Disassemble embedded closures as well. (name (or (and pdi (program-debug-info-name pdi))
(list "~A at 0x~X (~A free var~:p)" "anonymous procedure")))
(or (and pdi (program-debug-info-name pdi)) (push-addr! addr name)
"(anonymous procedure)") (list "~A at #x~X (~A free var~:p)" name addr nfree)))
addr
nfree)))
(('make-non-immediate dst target) (('make-non-immediate dst target)
(list "~@Y" (reference-scm target))) (let ((val (reference-scm target)))
(when (program? val)
(push-addr! (program-code val) val))
(list "~@Y" val)))
(('builtin-ref dst idx) (('builtin-ref dst idx)
(list "~A" (builtin-index->name idx))) (list "~A" (builtin-index->name idx)))
(((or 'static-ref 'static-set!) _ target) (((or 'static-ref 'static-set!) _ target)
(list "~@Y" (dereference-scm target))) (list "~@Y" (dereference-scm target)))
(((or 'free-ref 'free-set!) _ _ index)
(list "free var ~a" index))
(('resolve-module dst name public) (('resolve-module dst name public)
(list "~a" (if (zero? public) "private" "public"))) (list "~a" (if (zero? public) "private" "public")))
(('toplevel-box _ var-offset mod-offset sym-offset bound?) (('toplevel-box _ var-offset mod-offset sym-offset bound?)
@ -318,7 +321,7 @@ address of that offset."
(format port "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" (format port "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
addr info extra src)) addr info extra src))
(define (disassemble-buffer port bv start end context) (define (disassemble-buffer port bv start end context push-addr!)
(let ((labels (compute-labels bv start end)) (let ((labels (compute-labels bv start end))
(sources (find-program-sources (u32-offset->addr start context) (sources (find-program-sources (u32-offset->addr start context)
context))) context)))
@ -343,26 +346,39 @@ address of that offset."
(let ((pos (- offset start)) (let ((pos (- offset start))
(addr (u32-offset->addr offset context)) (addr (u32-offset->addr offset context))
(annotation (code-annotation elt len offset start labels (annotation (code-annotation elt len offset start labels
context))) context push-addr!)))
(print-info port pos (vector-ref labels pos) elt annotation (print-info port pos (vector-ref labels pos) elt annotation
(lookup-source addr)) (lookup-source addr))
(lp (+ offset len))))))))) (lp (+ offset len)))))))))
(define* (disassemble-program program #:optional (port (current-output-port))) (define (disassemble-addr addr label port)
(format port "Disassembly of ~A at #x~X:\n\n" label addr)
(cond (cond
((find-program-debug-info (program-code program)) ((find-program-debug-info addr)
=> (lambda (pdi) => (lambda (pdi)
(format port "Disassembly of ~S at #x~X:\n\n" program (let ((worklist '()))
(program-debug-info-addr pdi)) (define (push-addr! addr label)
(disassemble-buffer port (unless (assv addr worklist)
(program-debug-info-image pdi) (set! worklist (acons addr label worklist))))
(program-debug-info-u32-offset pdi) (disassemble-buffer port
(program-debug-info-u32-offset-end pdi) (program-debug-info-image pdi)
(program-debug-info-context pdi)))) (program-debug-info-u32-offset pdi)
(program-debug-info-u32-offset-end pdi)
(program-debug-info-context pdi)
push-addr!)
(for-each (match-lambda
((addr . label)
(display "\n----------------------------------------\n"
port)
(disassemble-addr addr label port)))
worklist))))
(else (else
(format port "Debugging information unavailable.~%"))) (format port "Debugging information unavailable.~%")))
(values)) (values))
(define* (disassemble-program program #:optional (port (current-output-port)))
(disassemble-addr (program-code program) program port))
(define (fold-code-range proc seed bv start end context raw?) (define (fold-code-range proc seed bv start end context raw?)
(define (cook code offset) (define (cook code offset)
(define (reference-scm target) (define (reference-scm target)
@ -446,7 +462,8 @@ address of that offset."
bv bv
(/ (+ base value) 4) (/ (+ base value) 4)
(/ (+ base value size) 4) (/ (+ base value size) 4)
ctx) ctx
(lambda (addr name) #t))
(display "\n\n" port))))) (display "\n\n" port)))))
(values)) (values))