Commit | Line | Data |
---|---|---|
d7236899 AW |
1 | ;;; Guile VM code converters |
2 | ||
581f410f | 3 | ;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc. |
d7236899 | 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) | |
96640816 | 23 | #:use-module (srfi srfi-1) |
d7236899 AW |
24 | #:use-module (system vm instruction) |
25 | #:use-module (system vm program) | |
26 | #:use-module (system base pmatch) | |
27 | #:use-module (language assembly) | |
28 | #:use-module (system base compile) | |
29 | #:export (disassemble)) | |
30 | ||
31 | (define (disassemble x) | |
32 | (format #t "Disassembly of ~A:\n\n" x) | |
33 | (call-with-values | |
34 | (lambda () (decompile x #:from 'value #:to 'assembly)) | |
35 | disassemble-load-program)) | |
36 | ||
37 | (define (disassemble-load-program asm env) | |
38 | (pmatch asm | |
56164a5a | 39 | ((load-program ,labels ,len ,meta . ,code) |
d7236899 | 40 | (let ((objs (and env (assq-ref env 'objects))) |
476e3572 | 41 | (free-vars (and env (assq-ref env 'free-vars))) |
d7236899 | 42 | (meta (and env (assq-ref env 'meta))) |
d7236899 | 43 | (blocs (and env (assq-ref env 'blocs))) |
d7236899 AW |
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)))) | |
98850fd7 AW |
64 | ((nop) |
65 | (lp (+ pos (byte-length asm)) (cdr code) programs)) | |
d7236899 AW |
66 | (else |
67 | (print-info pos asm | |
56164a5a AW |
68 | ;; FIXME: code-annotation for whether it's |
69 | ;; an arg or not, currently passing nargs=-1 | |
70 | (code-annotation end asm objs -1 blocs | |
a3f0ff0f | 71 | labels) |
d7236899 AW |
72 | (and=> (and srcs (assq end srcs)) source->string)) |
73 | (lp (+ pos (byte-length asm)) (cdr code) programs))))))) | |
74 | ||
476e3572 AW |
75 | (if (pair? free-vars) |
76 | (disassemble-free-vars free-vars)) | |
d7236899 AW |
77 | (if meta |
78 | (disassemble-meta meta)) | |
79 | ||
80 | ;; Disassemble other bytecode in it | |
81 | ;; FIXME: something about the module. | |
82 | (if objs | |
83 | (for-each | |
84 | (lambda (x) | |
85 | (if (program? x) | |
86 | (begin (display "----------------------------------------\n") | |
87 | (disassemble x)))) | |
81fd3152 | 88 | (cdr (vector->list objs)))))) |
d7236899 AW |
89 | (else |
90 | (error "bad load-program form" asm)))) | |
91 | ||
476e3572 AW |
92 | (define (disassemble-free-vars free-vars) |
93 | (display "Free variables:\n\n") | |
96640816 LC |
94 | (fold (lambda (free-var i) |
95 | (print-info i free-var #f #f) | |
96 | (+ 1 i)) | |
97 | 0 | |
98 | free-vars)) | |
d7236899 AW |
99 | |
100 | (define-macro (unless test . body) | |
101 | `(if (not ,test) (begin ,@body))) | |
102 | ||
103 | (define *uninteresting-props* '(name)) | |
104 | ||
105 | (define (disassemble-meta meta) | |
e5f5113c | 106 | (let ((props (filter (lambda (x) |
d7236899 | 107 | (not (memq (car x) *uninteresting-props*))) |
f39ede00 | 108 | (cdddr meta)))) |
d7236899 AW |
109 | (unless (null? props) |
110 | (display "Properties:\n\n") | |
111 | (for-each (lambda (x) (print-info #f x #f #f)) props) | |
112 | (newline)))) | |
113 | ||
114 | (define (source->string src) | |
115 | (format #f "~a:~a:~a" (or (source:file src) "(unknown file)") | |
e867d563 | 116 | (source:line-for-user src) (source:column src))) |
d7236899 AW |
117 | |
118 | (define (make-int16 byte1 byte2) | |
119 | (+ (* byte1 256) byte2)) | |
120 | ||
476e3572 | 121 | (define (code-annotation end-addr code objs nargs blocs labels) |
d7236899 AW |
122 | (let* ((code (assembly-unpack code)) |
123 | (inst (car code)) | |
124 | (args (cdr code))) | |
125 | (case inst | |
126 | ((list vector) | |
127 | (list "~a element~:p" (apply make-int16 args))) | |
128 | ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null) | |
a3f0ff0f | 129 | (list "-> ~A" (assq-ref labels (car args)))) |
8b652112 AW |
130 | ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt) |
131 | (list "-> ~A" (assq-ref labels (caddr args)))) | |
581f410f AW |
132 | ((bind-optionals/shuffle-or-br) |
133 | (list "-> ~A" (assq-ref labels (car (last-pair args))))) | |
d7236899 AW |
134 | ((object-ref) |
135 | (and objs (list "~s" (vector-ref objs (car args))))) | |
476e3572 | 136 | ((local-ref local-boxed-ref local-set local-boxed-set) |
d7236899 | 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)))))))) | |
e5cf9729 AW |
146 | ((assert-nargs-ee/locals assert-nargs-ge/locals) |
147 | (list "~a arg~:p, ~a local~:p" | |
148 | (logand (car args) #x7) (ash (car args) -3))) | |
476e3572 AW |
149 | ((free-ref free-boxed-ref free-boxed-set) |
150 | ;; FIXME: we can do better than this | |
151 | (list "(closure variable)")) | |
d7236899 AW |
152 | ((toplevel-ref toplevel-set) |
153 | (and objs | |
154 | (let ((v (vector-ref objs (car args)))) | |
155 | (if (and (variable? v) (variable-bound? v)) | |
156 | (list "~s" (variable-ref v)) | |
157 | (list "`~s'" v))))) | |
158 | ((mv-call) | |
a3f0ff0f | 159 | (list "MV -> ~A" (assq-ref labels (cadr args)))) |
9b7ca73c AW |
160 | ((prompt) |
161 | ;; the H is for handler | |
0bc8874c | 162 | (list "H -> ~A" (assq-ref labels (cadr args)))) |
d7236899 AW |
163 | (else |
164 | (and=> (assembly->object code) | |
165 | (lambda (obj) (list "~s" obj))))))) | |
166 | ||
167 | ;; i am format's daddy. | |
168 | (define (print-info addr info extra src) | |
169 | (format #t "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src)) |