Commit | Line | Data |
---|---|---|
d7236899 AW |
1 | ;;; Guile VM code converters |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
53befeb7 NJ |
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 | |
d7236899 AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language assembly disassemble) | |
22 | #:use-module (ice-9 format) | |
23 | #:use-module (system vm instruction) | |
24 | #:use-module (system vm program) | |
25 | #:use-module (system base pmatch) | |
26 | #:use-module (language assembly) | |
27 | #:use-module (system base compile) | |
28 | #:export (disassemble)) | |
29 | ||
30 | (define (disassemble x) | |
31 | (format #t "Disassembly of ~A:\n\n" x) | |
32 | (call-with-values | |
33 | (lambda () (decompile x #:from 'value #:to 'assembly)) | |
34 | disassemble-load-program)) | |
35 | ||
36 | (define (disassemble-load-program asm env) | |
37 | (pmatch asm | |
1f1ec13b | 38 | ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code) |
d7236899 AW |
39 | (let ((objs (and env (assq-ref env 'objects))) |
40 | (meta (and env (assq-ref env 'meta))) | |
41 | (exts (and env (assq-ref env 'exts))) | |
42 | (blocs (and env (assq-ref env 'blocs))) | |
43 | (bexts (and env (assq-ref env 'bexts))) | |
44 | (srcs (and env (assq-ref env 'sources)))) | |
45 | (let lp ((pos 0) (code code) (programs '())) | |
46 | (cond | |
47 | ((null? code) | |
48 | (newline) | |
49 | (for-each | |
50 | (lambda (sym+asm) | |
51 | (format #t "Embedded program ~A:\n\n" (car sym+asm)) | |
52 | (disassemble-load-program (cdr sym+asm) '())) | |
53 | (reverse! programs))) | |
54 | (else | |
55 | (let* ((asm (car code)) | |
56 | (len (byte-length asm)) | |
57 | (end (+ pos len))) | |
58 | (pmatch asm | |
59 | ((load-program . _) | |
60 | (let ((sym (gensym ""))) | |
61 | (print-info pos `(load-program ,sym) #f #f) | |
62 | (lp (+ pos (byte-length asm)) (cdr code) | |
63 | (acons sym asm programs)))) | |
64 | (else | |
65 | (print-info pos asm | |
a3f0ff0f AW |
66 | (code-annotation end asm objs nargs blocs bexts |
67 | labels) | |
d7236899 AW |
68 | (and=> (and srcs (assq end srcs)) source->string)) |
69 | (lp (+ pos (byte-length asm)) (cdr code) programs))))))) | |
70 | ||
71 | (if (pair? exts) | |
72 | (disassemble-externals exts)) | |
73 | (if meta | |
74 | (disassemble-meta meta)) | |
75 | ||
76 | ;; Disassemble other bytecode in it | |
77 | ;; FIXME: something about the module. | |
78 | (if objs | |
79 | (for-each | |
80 | (lambda (x) | |
81 | (if (program? x) | |
82 | (begin (display "----------------------------------------\n") | |
83 | (disassemble x)))) | |
81fd3152 | 84 | (cdr (vector->list objs)))))) |
d7236899 AW |
85 | (else |
86 | (error "bad load-program form" asm)))) | |
87 | ||
88 | (define (disassemble-objects objs) | |
89 | (display "Objects:\n\n") | |
90 | (let ((len (vector-length objs))) | |
91 | (do ((n 0 (1+ n))) | |
92 | ((= n len) (newline)) | |
93 | (print-info n (vector-ref objs n) #f #f)))) | |
94 | ||
95 | (define (disassemble-externals exts) | |
96 | (display "Externals:\n\n") | |
97 | (let ((len (length exts))) | |
98 | (do ((n 0 (1+ n)) | |
99 | (l exts (cdr l))) | |
100 | ((null? l) (newline)) | |
101 | (print-info n (car l) #f #f)))) | |
102 | ||
103 | (define-macro (unless test . body) | |
104 | `(if (not ,test) (begin ,@body))) | |
105 | ||
106 | (define *uninteresting-props* '(name)) | |
107 | ||
108 | (define (disassemble-meta meta) | |
109 | (let ((sources (cadr meta)) | |
110 | (props (filter (lambda (x) | |
111 | (not (memq (car x) *uninteresting-props*))) | |
112 | (cddr meta)))) | |
113 | (unless (null? props) | |
114 | (display "Properties:\n\n") | |
115 | (for-each (lambda (x) (print-info #f x #f #f)) props) | |
116 | (newline)))) | |
117 | ||
118 | (define (source->string src) | |
119 | (format #f "~a:~a:~a" (or (source:file src) "(unknown file)") | |
120 | (source:line src) (source:column src))) | |
121 | ||
122 | (define (make-int16 byte1 byte2) | |
123 | (+ (* byte1 256) byte2)) | |
124 | ||
a3f0ff0f | 125 | (define (code-annotation end-addr code objs nargs blocs bexts labels) |
d7236899 AW |
126 | (let* ((code (assembly-unpack code)) |
127 | (inst (car code)) | |
128 | (args (cdr code))) | |
129 | (case inst | |
130 | ((list vector) | |
131 | (list "~a element~:p" (apply make-int16 args))) | |
132 | ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null) | |
a3f0ff0f | 133 | (list "-> ~A" (assq-ref labels (car args)))) |
d7236899 AW |
134 | ((object-ref) |
135 | (and objs (list "~s" (vector-ref objs (car args))))) | |
136 | ((local-ref local-set) | |
137 | (and blocs | |
594d9d4c AW |
138 | (let lp ((bindings (list-ref blocs (car args)))) |
139 | (and (pair? bindings) | |
140 | (let ((b (car bindings))) | |
141 | (if (and (< (binding:start (car bindings)) end-addr) | |
142 | (>= (binding:end (car bindings)) end-addr)) | |
143 | (list "`~a'~@[ (arg)~]" | |
144 | (binding:name b) (< (binding:index b) nargs)) | |
145 | (lp (cdr bindings)))))))) | |
d7236899 AW |
146 | ((external-ref external-set) |
147 | (and bexts | |
148 | (if (< (car args) (length bexts)) | |
149 | (let ((b (list-ref bexts (car args)))) | |
150 | (list "`~a'~@[ (arg)~]" | |
151 | (binding:name b) (< (binding:index b) nargs))) | |
152 | (list "(closure variable)")))) | |
153 | ((toplevel-ref toplevel-set) | |
154 | (and objs | |
155 | (let ((v (vector-ref objs (car args)))) | |
156 | (if (and (variable? v) (variable-bound? v)) | |
157 | (list "~s" (variable-ref v)) | |
158 | (list "`~s'" v))))) | |
159 | ((mv-call) | |
a3f0ff0f | 160 | (list "MV -> ~A" (assq-ref labels (cadr args)))) |
d7236899 AW |
161 | (else |
162 | (and=> (assembly->object code) | |
163 | (lambda (obj) (list "~s" obj))))))) | |
164 | ||
165 | ;; i am format's daddy. | |
166 | (define (print-info addr info extra src) | |
167 | (format #t "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src)) | |
168 | ||
169 | (define (simplify x) | |
170 | (cond ((string? x) | |
171 | (cond ((string-index x #\newline) => | |
172 | (lambda (i) (set! x (substring x 0 i))))) | |
173 | (cond ((> (string-length x) 16) | |
174 | (set! x (string-append (substring x 0 13) "...")))))) | |
175 | x) | |
176 |