1 ;;; Guile VM code converters
3 ;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
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.
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.
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
21 (define-module (language assembly disassemble)
22 #:use-module (ice-9 format)
23 #:use-module (srfi srfi-1)
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))
31 (define (disassemble x)
32 (format #t "Disassembly of ~A:\n\n" x)
34 (lambda () (decompile x #:from 'value #:to 'assembly))
35 disassemble-load-program))
37 (define (disassemble-load-program asm env)
39 ((load-program ,labels ,len ,meta . ,code)
40 (let ((objs (and env (assq-ref env 'objects)))
41 (free-vars (and env (assq-ref env 'free-vars)))
42 (meta (and env (assq-ref env 'meta)))
43 (blocs (and env (assq-ref env 'blocs)))
44 (srcs (and env (assq-ref env 'sources))))
45 (let lp ((pos 0) (code code) (programs '()))
51 (format #t "Embedded program ~A:\n\n" (car sym+asm))
52 (disassemble-load-program (cdr sym+asm) '()))
55 (let* ((asm (car code))
56 (len (byte-length asm))
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))))
65 (lp (+ pos (byte-length asm)) (cdr code) programs))
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
72 (and=> (and srcs (assq end srcs)) source->string))
73 (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
76 (disassemble-free-vars free-vars))
78 (disassemble-meta meta))
80 ;; Disassemble other bytecode in it
81 ;; FIXME: something about the module.
86 (begin (display "----------------------------------------\n")
88 (cdr (vector->list objs))))))
90 (error "bad load-program form" asm))))
92 (define (disassemble-free-vars free-vars)
93 (display "Free variables:\n\n")
94 (fold (lambda (free-var i)
95 (print-info i free-var #f #f)
100 (define-macro (unless test . body)
101 `(if (not ,test) (begin ,@body)))
103 (define *uninteresting-props* '(name))
105 (define (disassemble-meta meta)
106 (let ((props (filter (lambda (x)
107 (not (memq (car x) *uninteresting-props*)))
109 (unless (null? props)
110 (display "Properties:\n\n")
111 (for-each (lambda (x) (print-info #f x #f #f)) props)
114 (define (source->string src)
115 (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
116 (source:line-for-user src) (source:column src)))
118 (define (make-int16 byte1 byte2)
119 (+ (* byte1 256) byte2))
121 (define (code-annotation end-addr code objs nargs blocs labels)
122 (let* ((code (assembly-unpack code))
127 (list "~a element~:p" (apply make-int16 args)))
129 br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null
130 br-if-nil br-if-not-nil)
131 (list "-> ~A" (assq-ref labels (car args))))
132 ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
133 (list "-> ~A" (assq-ref labels (caddr args))))
135 (and objs (list "~s" (vector-ref objs (car args)))))
136 ((local-ref local-boxed-ref local-set local-boxed-set)
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))))))))
146 ((free-ref free-boxed-ref free-boxed-set)
147 ;; FIXME: we can do better than this
148 (list "(closure variable)"))
149 ((toplevel-ref toplevel-set)
151 (let ((v (vector-ref objs (car args))))
152 (if (and (variable? v) (variable-bound? v))
153 (list "~s" (variable-ref v))
156 (list "MV -> ~A" (assq-ref labels (cadr args))))
158 ;; the H is for handler
159 (list "H -> ~A" (assq-ref labels (cadr args))))
161 (and=> (assembly->object code)
162 (lambda (obj) (list "~s" obj)))))))
164 ;; i am format's daddy.
165 (define (print-info addr info extra src)
166 (format #t "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src))