1; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
2; Part of Scheme 48 1.9.  See file COPYING for notices and license.
3
4; Authors: Richard Kelsey, Jonathan Rees, Martin Gasbichler, Mike Sperber
5
6;;;; Disassembler
7
8; This will need to track the template's offset.  Drat.
9
10; This defines a command processor command
11;      dis <expression>
12; that evaluates <expression> to obtain a procedure or lambda-expression,
13; which is then disassembled.
14
15; The assembly language is designed to be rereadable.  See env/assem.scm.
16
17(define-command-syntax 'dis "[<exp>]" "disassemble procedure"
18  '(&opt expression))
19
20; The command.  The thing to be disassembled defaults to the focus object (##).
21
22(define (dis . maybe-exp)
23  (disassemble (if (null? maybe-exp)
24		   (focus-object)
25		   (eval (car maybe-exp) (environment-for-commands)))))
26
27(define (disassemble obj)
28  (really-disassemble (coerce-to-template-or-code obj) 0)
29  (newline))
30
31(define (really-disassemble template-or-code level)
32    (let* ((template (if (template? template-or-code)
33                         template-or-code
34                         #f))
35           (code (if template
36                     (template-code template)
37                     template-or-code)))
38      (parse-template-code template code level disasm-attribution)))
39
40(define (disasm-init-template level template p-args push-template? push-env? push-closure?)
41  (if (template-name template)
42      (write (template-name template)))
43  (print-opcode (enum op protocol) 0 level)
44  (show-protocol p-args 0)
45  (if (or push-template? push-env? push-closure?)
46      (begin
47        (display " (push")
48	(if push-closure?
49	    (display " closure"))
50        (if push-env?
51            (display " env"))
52        (if push-template?
53            (display " template"))
54        (display #\))))
55  (display #\))
56  level)
57
58(define (disasm-attribute-literal literal index level)
59  level)
60
61(define (disasm-make-label target-pc)
62  target-pc)
63
64(define (disasm-at-label label level)
65  level)
66
67(define disasm-table (make-opcode-table
68                               (lambda (opcode template level pc len . args)
69                                 (print-opcode opcode pc level)
70                                 (print-opcode-args args)
71                                 (display #\))
72                                 level)))
73
74(define disasm-attribution
75  (make-attribution disasm-init-template disasm-attribute-literal
76                    disasm-table disasm-make-label disasm-at-label))
77
78(define-syntax define-disasm
79  (syntax-rules ()
80    ((define-disasm inst disasm)
81     (opcode-table-set! disasm-table (enum op inst) disasm))))
82
83;------------------------------
84(define-disasm protocol
85  (lambda (opcode template level pc len p-args)
86    (print-opcode opcode pc level)
87    (show-protocol (cdr p-args) pc)
88    (display #\))
89    level))
90
91(define (show-protocol p-args pc)
92  (let ((protocol (car p-args)))
93    (display #\space)
94    (cond ((<= protocol maximum-stack-args)
95           (display protocol))
96          ((= protocol two-byte-nargs-protocol)
97           (display (cadr p-args)))
98          ((= protocol two-byte-nargs+list-protocol)
99           (display (cadr p-args))
100           (display " +"))
101          ((= protocol ignore-values-protocol)
102           (display "discard all values"))
103          ((= protocol call-with-values-protocol)
104           (display "call-with-values")
105           (let ((target-pc (cadr p-args)))
106             (if (not (= pc target-pc))
107                 (begin
108                   (display #\space)
109                   (write `(=> ,(cadr p-args)))))))
110          ((= protocol args+nargs-protocol)
111           (display "args+nargs ")
112           (display (cadr p-args))
113           (display "+"))
114          ((= protocol nary-dispatch-protocol)
115           (display "nary-dispatch")
116           (for-each display-dispatch (cdr p-args) (list 0 1 2 "3+")))
117          ((= protocol big-stack-protocol)
118           (apply
119            (lambda (real-attribution stack-size)
120              (display "big-stack")
121              (show-protocol real-attribution pc)
122              (display #\space)
123              (display stack-size))
124            (cdr p-args)))
125          (else
126           (assertion-violation 'show-protocol "unknown protocol" protocol)))))
127
128(define (display-dispatch target-pc tag)
129  (if target-pc
130      (begin
131        (display #\space)
132        (display (list tag '=> target-pc)))))
133
134;------------------------------
135(define-disasm global
136  (lambda (opcode template level pc len index-to-template index-within-template)
137    (print-opcode opcode pc level)
138    (print-opcode-args (list index-to-template index-within-template))
139    (display #\space)
140    (display-global-reference template (cdr index-within-template))
141    (display #\))
142    level))
143
144(define-disasm set-global!
145  (lambda (opcode template level pc len index-to-template index-within-template)
146    (print-opcode opcode pc level)
147    (print-opcode-args (list index-to-template index-within-template))
148    (display #\space)
149    (display-global-reference template (cdr index-within-template))
150    (display #\))
151    level))
152
153(define (display-global-reference template index)
154  (let ((loc (if template
155		 (template-ref template index)
156		 #f)))
157    (cond ((location? loc)
158	   (write (or (location-name loc)
159		      `(location ,(location-id loc)))))
160	  (else
161	   (display #\')
162	   (write loc)))))
163
164
165;------------------------------
166(define (disasm-make-flat-env opcode template level pc len env-data-arg)
167  (let ((env-data (cdr env-data-arg)))
168    (print-opcode opcode pc level)
169    (display #\space)
170    (write (env-data-total-count env-data))
171    (display #\space)
172
173    (let ((closure-offsets (env-data-closure-offsets env-data)))
174      (if (not (null? closure-offsets))
175          (begin
176            (write (length closure-offsets))
177            (display-flat-env-closures env-data))
178          (write 0)))
179
180    (display #\space)
181    (display (env-data-frame-offsets env-data))
182
183    (for-each (lambda (env-offset)
184                (display #\space)
185                (display #\()
186                (display (car env-offset))
187                (display " => ")
188                (display (cdr env-offset))
189                (display #\)))
190              (env-data-env-offsets env-data))
191    (display #\))
192    level))
193
194(define (display-flat-env-closures env-data)
195  (display " (closures from ")
196  (display (env-data-maybe-template-index env-data))
197  (display #\:)
198  (for-each (lambda (offset)
199              (display #\space)
200              (display offset))
201            (env-data-closure-offsets env-data))
202  (display #\)))
203
204(define-disasm make-flat-env disasm-make-flat-env)
205(define-disasm make-big-flat-env disasm-make-flat-env)
206
207;------------------------------
208
209(define (display-cont-data cont-data)
210  (write-char #\space)
211  (display (list '=> (cont-data-pc cont-data)))
212  (write-char #\space)
213  (display (list 'depth (cont-data-depth cont-data)))
214  (write-char #\space)
215  (display (list 'template (cont-data-template cont-data)))
216  (write-char #\space)
217  (cond
218   ((cont-data-live-offsets cont-data)
219    => (lambda (offsets)
220	 (display (cons 'live offsets))))
221   (else
222    (display "all-live"))))
223
224(define-disasm cont-data
225  (lambda (opcode template level pc len cont-data-arg)
226    (print-opcode opcode pc level)
227    (display-cont-data (cdr cont-data-arg))
228    (display #\))
229    level))
230;------------------------------
231(define (display-shuffle opcode template level pc len moves-data)
232  (print-opcode opcode pc level)
233  (write-char #\space)
234  (let ((moves (cdr moves-data)))
235    (display (length moves))
236    (for-each (lambda (move)
237                (write-char #\space)
238                (display (list (car move) (cdr move))))
239              moves)
240    (write-char #\))
241    level))
242
243(define-disasm stack-shuffle! display-shuffle)
244(define-disasm big-stack-shuffle! display-shuffle)
245
246(define (write-instruction code template pc level write-sub-templates?)
247  ;; As in the previous version, WRITE-SUB-TEMPLATES? is ignored and
248  ;; sub templates are never written.
249  (call-with-values
250   (lambda ()
251     (parse-instruction template code pc level disasm-attribution))
252   (lambda (len level)
253     (+ pc len))))
254
255;------------------------------
256(define (print-opcode opcode pc level)
257  (newline-indent (* level 3))
258  (write-pc pc)
259  (display " (")
260  (write (enumerand->name opcode op)))
261
262; Generic opcode argument printer.
263
264(define (print-opcode-args args)
265  (for-each (lambda (arg)
266              (display #\space)
267              (print-opcode-arg arg))
268            args))
269
270; Print out the particular type of argument.
271
272; This works only for the generic argument types, the special types
273; are handled by the instruction disassemblers themselves
274
275(define (print-opcode-arg spec.arg)
276  (let ((spec (car spec.arg))
277        (arg (cdr spec.arg)))
278    (case spec
279      ((byte two-bytes nargs two-byte-nargs literal index two-byte-index
280             stack-index two-byte-stack-index)
281       (write arg))
282      ((offset)
283       (write `(=> ,arg)))
284      ((offset-)
285       (write `(=> ,arg)))
286      ((stob)
287       (write (enumerand->name arg stob)))
288      ((instr)
289       (write arg))
290      (else
291       (assertion-violation 'print-opcode-arg "unknown arg spec" spec)))))
292
293;----------------
294; Utilities.
295
296; Turn OBJ into a template, if possible.
297
298(define (coerce-to-template-or-code obj)
299  (cond ((template? obj)
300	 obj)
301	((closure? obj)
302	 (closure-template obj))
303	((continuation? obj)
304	 (or (continuation-template obj)
305	     (continuation-code obj)))
306	(else
307	 (assertion-violation 'coerce-to-template-or-code
308			      "expected a procedure or continuation" obj))))
309
310; Indenting and aligning the program counter.
311
312(define (newline-indent n)
313  (newline)
314  (do ((i n (- i 1)))
315      ((= i 0))
316    (display #\space)))
317
318(define (write-pc pc)
319  (if (< pc 100) (display " "))
320  (if (< pc 10) (display " "))
321  (write pc))
322