[bpt/guile.git] / module / system / vm / disassembler.scm

;;; Guile RTL disassembler

;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (system vm disassembler)
  #:use-module (system vm instruction)
  #:use-module (system vm elf)
  #:use-module (system vm debug)
  #:use-module (system vm program)
  #:use-module (system vm objcode)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-4)
  #:export (disassemble-program))

(define-syntax-rule (u32-ref buf n)
  (bytevector-u32-native-ref buf (* n 4)))

(define-syntax-rule (s32-ref buf n)
  (bytevector-s32-native-ref buf (* n 4)))

(define-syntax visit-opcodes
  (lambda (x)
    (syntax-case x ()
      ((visit-opcodes macro arg ...)
       (with-syntax (((inst ...)
                      (map (lambda (x) (datum->syntax #'macro x))
                           (rtl-instruction-list))))
         #'(begin
             (macro arg ... . inst)
             ...))))))

(eval-when (expand compile load eval)
  (define (id-append ctx a b)
    (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))

(define (unpack-scm n)
  (pointer->scm (make-pointer n)))

(define (unpack-s24 s)
  (if (zero? (logand s (ash 1 23)))
      s
      (- s (ash 1 24))))

(define (unpack-s32 s)
  (if (zero? (logand s (ash 1 31)))
      s
      (- s (ash 1 32))))

(define-syntax disassembler
  (lambda (x)
    (define (parse-first-word word type)
      (with-syntax ((word word))
        (case type
          ((U8_X24)
           #'())
          ((U8_U24)
           #'((ash word -8)))
          ((U8_L24)
           #'((unpack-s24 (ash word -8))))
          ((U8_R24)
           #'(#:rest (ash word -8)))
          ((U8_U8_I16)
           #'((logand (ash word -8) #xff)
              (ash word -16)))
          ((U8_U12_U12)
           #'((logand (ash word -8) #xfff)
              (ash word -20)))
          ((U8_U8_U8_U8)
           #'((logand (ash word -8) #xff)
              (logand (ash word -16) #xff)
              (ash word -24)))
          (else
           (error "bad kind" type)))))

    (define (parse-tail-word word type)
      (with-syntax ((word word))
        (case type
          ((U8_X24)
           #'((logand word #ff)))
          ((U8_U24)
           #'((logand word #xff)
              (ash word -8)))
          ((U8_L24)
           #'((logand word #xff)
              (unpack-s24 (ash word -8))))
          ((U8_R24)
           #'((logand word #xff)
              #:rest (ash word -8)))
          ((U8_U8_I16)
           #'((logand word #xff)
              (logand (ash word -8) #xff)
              (ash word -16)))
          ((U8_U12_U12)
           #'((logand word #xff)
              (logand (ash word -8) #xfff)
              (ash word -20)))
          ((U8_U8_U8_U8)
           #'((logand word #xff)
              (logand (ash word -8) #xff)
              (logand (ash word -16) #xff)
              (ash word -24)))
          ((U32)
           #'(word))
          ((I32)
           #'(word))
          ((A32)
           #'(word))
          ((B32)
           #'(word))
          ((N32)
           #'((unpack-s32 word)))
          ((S32)
           #'((unpack-s32 word)))
          ((L32)
           #'((unpack-s32 word)))
          ((LO32)
           #'((unpack-s32 word)))
          ((X8_U24)
           #'((ash word -8)))
          ((X8_U12_U12)
           #'((logand (ash word -8) #xfff)
              (ash word -20)))
          ((X8_R24)
           #'(#:rest (ash word -8)))
          ((X8_L24)
           #'((unpack-s24 (ash word -8))))
          ((B1_X7_L24)
           #'((not (zero? (logand word #x1)))
              (unpack-s24 (ash word -8))))
          ((B1_U7_L24)
           #'((not (zero? (logand word #x1)))
              (logand (ash word -1) #x7f)
              (unpack-s24 (ash word -8))))
          (else
           (error "bad kind" type)))))

    (syntax-case x ()
      ((_ name opcode word0 word* ...)
       (let ((vars (generate-temporaries #'(word* ...))))
         (with-syntax (((word* ...) vars)
                       ((n ...) (map 1+ (iota (length #'(word* ...)))))
                       ((asm ...)
                        (parse-first-word #'first (syntax->datum #'word0)))
                       (((asm* ...) ...)
                        (map (lambda (word type)
                               (parse-tail-word word type))
                             vars
                             (syntax->datum #'(word* ...)))))
           #'(lambda (buf offset first)
               (let ((word* (u32-ref buf (+ offset n)))
                     ...)
                 (values (+ 1 (length '(word* ...)))
                         (list 'name asm ... asm* ... ...))))))))))

(define (disasm-invalid buf offset first)
  (error "bad instruction" (logand first #xff) first buf offset))

(define disassemblers (make-vector 256 disasm-invalid))

(define-syntax define-disassembler
  (lambda (x)
    (syntax-case x ()
      ((_ name opcode kind arg ...)
       (with-syntax ((parse (id-append #'name #'parse- #'name)))
         #'(let ((parse (disassembler name opcode arg ...)))
             (vector-set! disassemblers opcode parse)))))))

(visit-opcodes define-disassembler)

;; -> len list
(define (disassemble-one buf offset)
  (let ((first (u32-ref buf offset)))
    (call-with-values
        (lambda ()
          ((vector-ref disassemblers (logand first #xff)) buf offset first))
      (lambda (len list)
        (match list
          ((head ... #:rest rest)
           (let lp ((n 0) (rhead (reverse head)))
             (if (= n rest)
                 (values (+ len n) (reverse rhead))
                 (lp (1+ n)
                     (cons (u32-ref buf (+ offset len n)) rhead)))))
          (_ (values len list)))))))

(define (u32-offset->addr offset context)
  "Given an offset into an image in 32-bit units, return the absolute
address of that offset."
  (+ (debug-context-base context) (* offset 4)))

(define (code-annotation code len offset start labels context)
  ;; FIXME: Print names for register loads and stores that correspond to
  ;; access to named locals.
  (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 'br
          'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
          'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
          'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal
          'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
     (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
    (('prompt tag flags handler)
     ;; The H is for handler.
     (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
    (((or 'make-short-immediate 'make-long-immediate) _ imm)
     (list "~S" (unpack-scm imm)))
    (('make-long-long-immediate _ high low)
     (list "~S" (unpack-scm (logior (ash high 32) low))))
    (('assert-nargs-ee/locals nargs locals)
     ;; The nargs includes the procedure.
     (list "~a arg~:p, ~a local~:p" (1- nargs) locals))
    (('tail-call nargs proc)
     (list "~a arg~:p" nargs))
    (('make-closure dst target nfree)
     (let* ((addr (u32-offset->addr (+ offset target) context))
            (pdi (find-program-debug-info addr context)))
       ;; FIXME: Disassemble embedded closures as well.
       (list "~A at 0x~X (~A free var~:p)"
             (or (and pdi (program-debug-info-name pdi))
                 "(anonymous procedure)")
             addr
             nfree)))
    (('make-non-immediate dst target)
     (list "~@Y" (reference-scm target)))
    (((or 'static-ref 'static-set!) _ target)
     (list "~@Y" (dereference-scm target)))
    (('link-procedure! src target)
     (let* ((addr (u32-offset->addr (+ offset target) context))
            (pdi (find-program-debug-info addr context)))
       (list "~A at 0x~X"
             (or (and pdi (program-debug-info-name pdi))
                 "(anonymous procedure)")
             addr)))
    (('resolve-module dst name public)
     (list "~a" (if (zero? public) "private" "public")))
    (((or 'toplevel-ref 'toplevel-set!) _ var-offset mod-offset sym-offset)
     (list "`~A'" (dereference-scm sym-offset)))
    (((or 'module-ref 'module-set!) _ var-offset mod-name-offset sym-offset)
     (let ((mod-name (reference-scm mod-name-offset)))
       (list "`(~A ~A ~A)'" (if (car mod-name) '@ '@@) (cdr mod-name)
             (dereference-scm sym-offset))))
    (('load-typed-array dst type shape target len)
     (let ((addr (u32-offset->addr (+ offset target) context)))
       (list "~a bytes from #x~X" len addr)))
    (_ #f)))

(define (compute-labels bv start end)
  (let ((labels (make-vector (- end start) #f)))
    (define (add-label! pos header)
      (unless (vector-ref labels (- pos start))
        (vector-set! labels (- pos start) header)))

    (let lp ((offset start))
      (when (< offset end)
        (call-with-values (lambda () (disassemble-one bv offset))
          (lambda (len elt)
            (match elt
              ((inst arg ...)
               (case inst
                 ((br
                   br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
                   br-if-true br-if-null br-if-nil br-if-pair br-if-struct
                   br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
                   br-if-= br-if-< br-if-<= br-if-> br-if->=)
                  (match arg
                    ((_ ... target)
                     (add-label! (+ offset target) "L"))))
                 ((prompt)
                  (match arg
                    ((_ ... target)
                     (add-label! (+ offset target) "H"))))
                 ((call call/values)
                  (let* ((MVRA (+ offset len))
                         (RA (+ MVRA 1)))
                    (add-label! MVRA "MVRA")
                    (add-label! RA "RA"))))))
            (lp (+ offset len))))))
    (let lp ((offset start) (n 1))
      (when (< offset end)
        (let* ((pos (- offset start))
               (label (vector-ref labels pos)))
          (if label
              (begin
                (vector-set! labels
                             pos
                             (string->symbol
                              (string-append label (number->string n))))
                (lp (1+ offset) (1+ n)))
              (lp (1+ offset) n)))))
    labels))

(define (print-info port addr label info extra src)
  (when label
    (format port "~A:\n" label))
  (format port "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
          addr info extra src))

(define (disassemble-buffer port bv start end context)
  (let ((labels (compute-labels bv start end)))
    (let lp ((offset start))
      (when (< offset end)
        (call-with-values (lambda () (disassemble-one bv offset))
          (lambda (len elt)
            (let ((pos (- offset start))
                  (annotation (code-annotation elt len offset start labels
                                               context)))
              (print-info port pos (vector-ref labels pos) elt annotation #f)
              (lp (+ offset len)))))))))

(define* (disassemble-program program #:optional (port (current-output-port)))
  (cond
   ((find-program-debug-info (rtl-program-code program))
    => (lambda (pdi)
         (format port "Disassembly of ~S at #x~X:\n\n" program
                 (program-debug-info-addr pdi))
         (disassemble-buffer port
                             (program-debug-info-image pdi)
                             (program-debug-info-u32-offset pdi)
                             (program-debug-info-u32-offset-end pdi)
                             (program-debug-info-context pdi))))
   (else
    (format port "Debugging information unavailable.~%")))
  (values))
Commit	Line	Data
82e299f3 AW	1	;;; Guile RTL disassembler
	2
	3	;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
	4	;;;
	5	;;; This library is free software; you can redistribute it and/or
	6	;;; modify it under the terms of the GNU Lesser General Public
	7	;;; License as published by the Free Software Foundation; either
	8	;;; version 3 of the License, or (at your option) any later version.
	9	;;;
	10	;;; This library is distributed in the hope that it will be useful,
	11	;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;; Lesser General Public License for more details.
	14	;;;
	15	;;; You should have received a copy of the GNU Lesser General Public
	16	;;; License along with this library; if not, write to the Free Software
	17	;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
	19	;;; Code:
	20
	21	(define-module (system vm disassembler)
	22	#:use-module (system vm instruction)
	23	#:use-module (system vm elf)
	24	#:use-module (system vm debug)
	25	#:use-module (system vm program)
	26	#:use-module (system vm objcode)
	27	#:use-module (system foreign)
	28	#:use-module (rnrs bytevectors)
	29	#:use-module (ice-9 format)
	30	#:use-module (ice-9 match)
	31	#:use-module (ice-9 vlist)
	32	#:use-module (srfi srfi-1)
	33	#:use-module (srfi srfi-4)
	34	#:export (disassemble-program))
	35
	36	(define-syntax-rule (u32-ref buf n)
	37	(bytevector-u32-native-ref buf (* n 4)))
	38
	39	(define-syntax-rule (s32-ref buf n)
	40	(bytevector-s32-native-ref buf (* n 4)))
	41
	42	(define-syntax visit-opcodes
	43	(lambda (x)
	44	(syntax-case x ()
	45	((visit-opcodes macro arg ...)
	46	(with-syntax (((inst ...)
	47	(map (lambda (x) (datum->syntax #'macro x))
	48	(rtl-instruction-list))))
	49	#'(begin
	50	(macro arg ... . inst)
	51	...))))))
	52
	53	(eval-when (expand compile load eval)
	54	(define (id-append ctx a b)
	55	(datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
	56
	57	(define (unpack-scm n)
	58	(pointer->scm (make-pointer n)))
	59
	60	(define (unpack-s24 s)
	61	(if (zero? (logand s (ash 1 23)))
	62	s
	63	(- s (ash 1 24))))
	64
65	(define (unpack-s32 s)
66	(if (zero? (logand s (ash 1 31)))
67	s
68	(- s (ash 1 32))))
69
70	(define-syntax disassembler
71	(lambda (x)
72	(define (parse-first-word word type)
73	(with-syntax ((word word))
74	(case type
75	((U8_X24)
76	#'())
77	((U8_U24)
78	#'((ash word -8)))
79	((U8_L24)
80	#'((unpack-s24 (ash word -8))))
81	((U8_R24)
82	#'(#:rest (ash word -8)))
83	((U8_U8_I16)
84	#'((logand (ash word -8) #xff)
85	(ash word -16)))
86	((U8_U12_U12)
87	#'((logand (ash word -8) #xfff)
88	(ash word -20)))
89	((U8_U8_U8_U8)
90	#'((logand (ash word -8) #xff)
91	(logand (ash word -16) #xff)
92	(ash word -24)))
93	(else
94	(error "bad kind" type)))))
95
96	(define (parse-tail-word word type)
97	(with-syntax ((word word))
98	(case type
99	((U8_X24)
100	#'((logand word #ff)))
101	((U8_U24)
102	#'((logand word #xff)
103	(ash word -8)))
104	((U8_L24)
105	#'((logand word #xff)
106	(unpack-s24 (ash word -8))))
107	((U8_R24)
108	#'((logand word #xff)
109	#:rest (ash word -8)))
110	((U8_U8_I16)
111	#'((logand word #xff)
112	(logand (ash word -8) #xff)
113	(ash word -16)))
114	((U8_U12_U12)
115	#'((logand word #xff)
116	(logand (ash word -8) #xfff)
117	(ash word -20)))
118	((U8_U8_U8_U8)
119	#'((logand word #xff)
120	(logand (ash word -8) #xff)
121	(logand (ash word -16) #xff)
122	(ash word -24)))
123	((U32)
124	#'(word))
125	((I32)
126	#'(word))
127	((A32)
128	#'(word))
129	((B32)
130	#'(word))
131	((N32)
132	#'((unpack-s32 word)))
133	((S32)
134	#'((unpack-s32 word)))
135	((L32)
136	#'((unpack-s32 word)))
137	((LO32)
138	#'((unpack-s32 word)))
139	((X8_U24)
140	#'((ash word -8)))
141	((X8_U12_U12)
142	#'((logand (ash word -8) #xfff)
143	(ash word -20)))
144	((X8_R24)
145	#'(#:rest (ash word -8)))
146	((X8_L24)
147	#'((unpack-s24 (ash word -8))))
148	((B1_X7_L24)
149	#'((not (zero? (logand word #x1)))
150	(unpack-s24 (ash word -8))))
151	((B1_U7_L24)
152	#'((not (zero? (logand word #x1)))
153	(logand (ash word -1) #x7f)
154	(unpack-s24 (ash word -8))))
155	(else
156	(error "bad kind" type)))))
157
158	(syntax-case x ()
159	((_ name opcode word0 word* ...)
160	(let ((vars (generate-temporaries #'(word* ...))))
161	(with-syntax (((word* ...) vars)
162	((n ...) (map 1+ (iota (length #'(word* ...)))))
163	((asm ...)
164	(parse-first-word #'first (syntax->datum #'word0)))
165	(((asm* ...) ...)
166	(map (lambda (word type)
167	(parse-tail-word word type))
168	vars
169	(syntax->datum #'(word* ...)))))
170	#'(lambda (buf offset first)
171	(let ((word* (u32-ref buf (+ offset n)))
172	...)
173	(values (+ 1 (length '(word* ...)))
174	(list 'name asm ... asm* ... ...))))))))))
175
176	(define (disasm-invalid buf offset first)
177	(error "bad instruction" (logand first #xff) first buf offset))
178
179	(define disassemblers (make-vector 256 disasm-invalid))
180
181	(define-syntax define-disassembler
182	(lambda (x)
183	(syntax-case x ()
2a294c7c	184	((_ name opcode kind arg ...)
82e299f3 AW	185	(with-syntax ((parse (id-append #'name #'parse- #'name)))
	186	#'(let ((parse (disassembler name opcode arg ...)))
	187	(vector-set! disassemblers opcode parse)))))))
	188
	189	(visit-opcodes define-disassembler)
	190
	191	;; -> len list
	192	(define (disassemble-one buf offset)
	193	(let ((first (u32-ref buf offset)))
	194	(call-with-values
	195	(lambda ()
	196	((vector-ref disassemblers (logand first #xff)) buf offset first))
	197	(lambda (len list)
	198	(match list
	199	((head ... #:rest rest)
	200	(let lp ((n 0) (rhead (reverse head)))
	201	(if (= n rest)
	202	(values (+ len n) (reverse rhead))
	203	(lp (1+ n)
	204	(cons (u32-ref buf (+ offset len n)) rhead)))))
	205	(_ (values len list)))))))
	206
	207	(define (u32-offset->addr offset context)
	208	"Given an offset into an image in 32-bit units, return the absolute
	209	address of that offset."
	210	(+ (debug-context-base context) (* offset 4)))
	211
	212	(define (code-annotation code len offset start labels context)
	213	;; FIXME: Print names for register loads and stores that correspond to
	214	;; access to named locals.
	215	(define (reference-scm target)
	216	(unpack-scm (u32-offset->addr (+ offset target) context)))
	217
	218	(define (dereference-scm target)
	219	(let ((addr (u32-offset->addr (+ offset target)
	220	context)))
	221	(pointer->scm
	222	(dereference-pointer (make-pointer addr)))))
	223
	224	(match code
	225	(((or 'br
	226	'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
	227	'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
	228	'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal
	229	'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
	230	(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
	231	(('prompt tag flags handler)
	232	;; The H is for handler.
	233	(list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
	234	(((or 'make-short-immediate 'make-long-immediate) _ imm)
	235	(list "~S" (unpack-scm imm)))
	236	(('make-long-long-immediate _ high low)
	237	(list "~S" (unpack-scm (logior (ash high 32) low))))
	238	(('assert-nargs-ee/locals nargs locals)
7396d216 AW	239	;; The nargs includes the procedure.
7396d216 AW	240	(list "~a arg~:p, ~a local~:p" (1- nargs) locals))
82e299f3 AW	241	(('tail-call nargs proc)
82e299f3 AW	242	(list "~a arg~:p" nargs))
7396d216	243	(('make-closure dst target nfree)
82e299f3 AW	244	(let* ((addr (u32-offset->addr (+ offset target) context))
	245	(pdi (find-program-debug-info addr context)))
	246	;; FIXME: Disassemble embedded closures as well.
7396d216	247	(list "~A at 0x~X (~A free var~:p)"
82e299f3 AW	248	(or (and pdi (program-debug-info-name pdi))
82e299f3 AW	249	"(anonymous procedure)")
7396d216 AW	250	addr
7396d216 AW	251	nfree)))
82e299f3 AW	252	(('make-non-immediate dst target)
	253	(list "~@Y" (reference-scm target)))
	254	(((or 'static-ref 'static-set!) _ target)
	255	(list "~@Y" (dereference-scm target)))
	256	(('link-procedure! src target)
	257	(let* ((addr (u32-offset->addr (+ offset target) context))
	258	(pdi (find-program-debug-info addr context)))
	259	(list "~A at 0x~X"
	260	(or (and pdi (program-debug-info-name pdi))
	261	"(anonymous procedure)")
	262	addr)))
	263	(('resolve-module dst name public)
	264	(list "~a" (if (zero? public) "private" "public")))
	265	(((or 'toplevel-ref 'toplevel-set!) _ var-offset mod-offset sym-offset)
	266	(list "`~A'" (dereference-scm sym-offset)))
	267	(((or 'module-ref 'module-set!) _ var-offset mod-name-offset sym-offset)
	268	(let ((mod-name (reference-scm mod-name-offset)))
	269	(list "`(~A ~A ~A)'" (if (car mod-name) '@ '@@) (cdr mod-name)
	270	(dereference-scm sym-offset))))
	271	(('load-typed-array dst type shape target len)
	272	(let ((addr (u32-offset->addr (+ offset target) context)))
	273	(list "~a bytes from #x~X" len addr)))
	274	(_ #f)))
	275
	276	(define (compute-labels bv start end)
	277	(let ((labels (make-vector (- end start) #f)))
	278	(define (add-label! pos header)
	279	(unless (vector-ref labels (- pos start))
	280	(vector-set! labels (- pos start) header)))
	281
	282	(let lp ((offset start))
	283	(when (< offset end)
	284	(call-with-values (lambda () (disassemble-one bv offset))
	285	(lambda (len elt)
	286	(match elt
	287	((inst arg ...)
	288	(case inst
	289	((br
	290	br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
	291	br-if-true br-if-null br-if-nil br-if-pair br-if-struct
	292	br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
	293	br-if-= br-if-< br-if-<= br-if-> br-if->=)
	294	(match arg
	295	((_ ... target)
	296	(add-label! (+ offset target) "L"))))
	297	((prompt)
	298	(match arg
	299	((_ ... target)
	300	(add-label! (+ offset target) "H"))))
	301	((call call/values)
	302	(let* ((MVRA (+ offset len))
	303	(RA (+ MVRA 1)))
	304	(add-label! MVRA "MVRA")
	305	(add-label! RA "RA"))))))
	306	(lp (+ offset len))))))
	307	(let lp ((offset start) (n 1))
	308	(when (< offset end)
	309	(let* ((pos (- offset start))
	310	(label (vector-ref labels pos)))
	311	(if label
	312	(begin
	313	(vector-set! labels
	314	pos
	315	(string->symbol
316	(string-append label (number->string n))))
317	(lp (1+ offset) (1+ n)))
318	(lp (1+ offset) n)))))
319	labels))
320
321	(define (print-info port addr label info extra src)
322	(when label
323	(format port "~A:\n" label))
324	(format port "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
325	addr info extra src))
326
327	(define (disassemble-buffer port bv start end context)
328	(let ((labels (compute-labels bv start end)))
329	(let lp ((offset start))
330	(when (< offset end)
331	(call-with-values (lambda () (disassemble-one bv offset))
332	(lambda (len elt)
333	(let ((pos (- offset start))
334	(annotation (code-annotation elt len offset start labels
335	context)))
336	(print-info port pos (vector-ref labels pos) elt annotation #f)
337	(lp (+ offset len)))))))))
338
339	(define* (disassemble-program program #:optional (port (current-output-port)))
340	(cond
341	((find-program-debug-info (rtl-program-code program))
342	=> (lambda (pdi)
343	(format port "Disassembly of ~S at #x~X:\n\n" program
344	(program-debug-info-addr pdi))
345	(disassemble-buffer port
346	(program-debug-info-image pdi)
347	(program-debug-info-u32-offset pdi)
348	(program-debug-info-u32-offset-end pdi)
349	(program-debug-info-context pdi))))
350	(else
351	(format port "Debugging information unavailable.~%")))
352	(values))