Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Guile VM Disassembler |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (system vm disasm) | |
1a1a10d3 AW |
23 | #:use-module (system base pmatch) |
24 | #:use-module (system vm objcode) | |
25 | #:use-module (system vm program) | |
26 | #:use-module (system vm conv) | |
27 | #:use-module (ice-9 regex) | |
28 | #:use-module (ice-9 format) | |
29 | #:use-module (ice-9 receive) | |
30 | #:export (disassemble-objcode disassemble-program disassemble-bytecode)) | |
4bfb26f5 | 31 | |
8f5cfc81 KN |
32 | (define (disassemble-objcode objcode . opts) |
33 | (let* ((prog (objcode->program objcode)) | |
34 | (arity (program-arity prog)) | |
af988bbf KN |
35 | (nlocs (arity:nlocs arity)) |
36 | (nexts (arity:nexts arity)) | |
8f5cfc81 KN |
37 | (bytes (program-bytecode prog))) |
38 | (format #t "Disassembly of ~A:\n\n" objcode) | |
39 | (format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts) | |
40 | (disassemble-bytecode bytes #f))) | |
17e90c5e KN |
41 | |
42 | (define (disassemble-program prog . opts) | |
43 | (let* ((arity (program-arity prog)) | |
af988bbf KN |
44 | (nargs (arity:nargs arity)) |
45 | (nrest (arity:nrest arity)) | |
46 | (nlocs (arity:nlocs arity)) | |
47 | (nexts (arity:nexts arity)) | |
17e90c5e | 48 | (bytes (program-bytecode prog)) |
41f248a8 | 49 | (objs (program-objects prog)) |
81aae202 | 50 | (meta (program-meta prog)) |
41f248a8 | 51 | (exts (program-external prog))) |
17e90c5e KN |
52 | ;; Disassemble this bytecode |
53 | (format #t "Disassembly of ~A:\n\n" prog) | |
3616e9e9 | 54 | (format #t "nargs = ~A nrest = ~A nlocs = ~A nexts = ~A\n\n" |
4bfb26f5 | 55 | nargs nrest nlocs nexts) |
17e90c5e KN |
56 | (format #t "Bytecode:\n\n") |
57 | (disassemble-bytecode bytes objs) | |
58 | (if (> (vector-length objs) 0) | |
59 | (disassemble-objects objs)) | |
41f248a8 KN |
60 | (if (pair? exts) |
61 | (disassemble-externals exts)) | |
81aae202 | 62 | (if meta |
709f95af | 63 | (disassemble-meta prog (meta))) |
17e90c5e KN |
64 | ;; Disassemble other bytecode in it |
65 | (for-each | |
66 | (lambda (x) | |
67 | (if (program? x) | |
68 | (begin (display "----------------------------------------\n") | |
69 | (apply disassemble-program x opts)))) | |
70 | (vector->list objs)))) | |
71 | ||
4bfb26f5 | 72 | (define (disassemble-bytecode bytes objs) |
17e90c5e | 73 | (let ((decode (make-byte-decoder bytes)) |
efbd5892 AW |
74 | (programs '())) |
75 | (define (lp addr code) | |
76 | (pmatch code | |
77 | (#f (newline)) | |
78 | ((load-program ,x) | |
79 | (let ((sym (gensym ""))) | |
80 | (set! programs (acons sym x programs)) | |
81 | (print-info addr (format #f "(load-program #~A)" sym) #f))) | |
82 | (else | |
83 | (print-info addr (list->info code) | |
84 | (original-value addr code objs)))) | |
85 | (if code (call-with-values decode lp))) | |
86 | (call-with-values decode lp) | |
17e90c5e | 87 | (for-each (lambda (sym+bytes) |
efbd5892 AW |
88 | (format #t "Bytecode #~A:\n\n" (car sym+bytes)) |
89 | (disassemble-bytecode (cdr sym+bytes) #f)) | |
90 | (reverse! programs)))) | |
17e90c5e KN |
91 | |
92 | (define (disassemble-objects objs) | |
93 | (display "Objects:\n\n") | |
94 | (let ((len (vector-length objs))) | |
95 | (do ((n 0 (1+ n))) | |
96 | ((= n len) (newline)) | |
97 | (let ((info (object->string (vector-ref objs n)))) | |
98 | (print-info n info #f))))) | |
99 | ||
41f248a8 KN |
100 | (define (disassemble-externals exts) |
101 | (display "Externals:\n\n") | |
102 | (let ((len (length exts))) | |
103 | (do ((n 0 (1+ n)) | |
104 | (l exts (cdr l))) | |
105 | ((null? l) (newline)) | |
106 | (let ((info (object->string (car l)))) | |
107 | (print-info n info #f))))) | |
108 | ||
81aae202 AW |
109 | (define-macro (unless test . body) |
110 | `(if (not ,test) (begin ,@body))) | |
111 | ||
709f95af AW |
112 | (define (disassemble-bindings prog bindings) |
113 | (let* ((nargs (arity:nargs (program-arity prog))) | |
114 | (args (if (zero? nargs) '() (cdar bindings))) | |
115 | (nonargs (if (zero? nargs) bindings (cdr bindings)))) | |
116 | (unless (null? args) | |
117 | (display "Arguments:\n\n") | |
118 | (for-each (lambda (bind n) | |
119 | (print-info n | |
120 | (format #f "~a[~a]: ~a" | |
6cdcb824 | 121 | (if (cadr bind) 'external 'local) |
709f95af AW |
122 | (caddr bind) (car bind)) |
123 | #f)) | |
124 | args | |
125 | (iota nargs)) | |
126 | (newline)) | |
127 | (unless (null? nonargs) | |
128 | (display "Bindings:\n\n") | |
129 | (for-each (lambda (start binds end) | |
130 | (for-each (lambda (bind) | |
131 | (print-info (format #f "~a-~a" start end) | |
132 | (format #f "~a[~a]: ~a" | |
6cdcb824 | 133 | (if (cadr bind) 'external 'local) |
709f95af AW |
134 | (caddr bind) (car bind)) |
135 | #f)) | |
136 | binds)) | |
137 | (map car (filter cdr nonargs)) | |
138 | (map cdr (filter cdr nonargs)) | |
139 | (map car (filter (lambda (x) (not (cdr x))) nonargs))) | |
140 | (newline)))) | |
141 | ||
142 | (define (disassemble-meta program meta) | |
81aae202 AW |
143 | (let ((bindings (car meta)) |
144 | (sources (cadr meta)) | |
145 | (props (cddr meta))) | |
146 | (unless (null? bindings) | |
709f95af | 147 | (disassemble-bindings program bindings)) |
81aae202 AW |
148 | (unless (null? sources) |
149 | (display "Sources:\n\n") | |
150 | (for-each (lambda (x) | |
151 | (print-info (car x) (list->info (cdr x)) #f)) | |
152 | sources) | |
153 | (newline)) | |
154 | (unless (null? props) | |
155 | (display "Properties:\n\n") | |
156 | (for-each (lambda (x) (print-info #f x #f)) props) | |
157 | (newline)))) | |
17e90c5e | 158 | |
46cd9a34 | 159 | (define (original-value addr code objs) |
95b6ad34 AW |
160 | (let* ((code (code-unpack code)) |
161 | (inst (car code)) | |
162 | (args (cdr code))) | |
163 | (case inst | |
164 | ((list vector) | |
165 | (let ((len (+ (* (cadr code) 256) (caddr code)))) | |
166 | (format #f "~a element~a" len (if (> len 1) "s" "")))) | |
167 | ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null) | |
168 | (let ((offset (+ (* (car args) 256) (cadr args)))) | |
169 | (format #f "-> ~A" (+ addr offset 3)))) | |
170 | ((object-ref) | |
171 | (if objs (object->string (vector-ref objs (car args))) #f)) | |
172 | ((mv-call) | |
173 | (let ((offset (+ (* (caddr code) 256) (cadddr code)))) | |
174 | (format #f "MV -> ~A" (+ addr offset 4)))) | |
175 | (else | |
176 | (and=> (code->object code) object->string))))) | |
17e90c5e | 177 | |
a80be762 | 178 | (define (list->info list) |
ac99cb0c | 179 | (object->string list)) |
17e90c5e | 180 | |
fa19602c LC |
181 | ; (define (u8vector->string vec) |
182 | ; (list->string (map integer->char (u8vector->list vec)))) | |
183 | ||
184 | ; (case (car list) | |
185 | ; ((link) | |
186 | ; (object->string `(link ,(u8vector->string (cadr list))))) | |
187 | ; (else | |
188 | ; (object->string list)))) | |
189 | ||
17e90c5e KN |
190 | (define (print-info addr info extra) |
191 | (if extra | |
46cd9a34 | 192 | (format #t "~4@A ~32A;; ~A\n" addr info extra) |
17e90c5e | 193 | (format #t "~4@A ~A\n" addr info))) |
f21dfea6 KN |
194 | |
195 | (define (simplify x) | |
196 | (cond ((string? x) | |
197 | (cond ((string-index x #\newline) => | |
198 | (lambda (i) (set! x (substring x 0 i))))) | |
199 | (cond ((> (string-length x) 16) | |
200 | (set! x (string-append (substring x 0 13) "...")))))) | |
201 | x) |