1 ;;; Guile VM code converters
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
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)
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.
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.
22 (define-module (language assembly disassemble)
23 #:use-module (ice-9 format)
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 ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
40 (let ((objs (and env (assq-ref env 'objects)))
41 (meta (and env (assq-ref env 'meta)))
42 (exts (and env (assq-ref env 'exts)))
43 (blocs (and env (assq-ref env 'blocs)))
44 (bexts (and env (assq-ref env 'bexts)))
45 (srcs (and env (assq-ref env 'sources))))
46 (let lp ((pos 0) (code code) (programs '()))
52 (format #t "Embedded program ~A:\n\n" (car sym+asm))
53 (disassemble-load-program (cdr sym+asm) '()))
56 (let* ((asm (car code))
57 (len (byte-length asm))
61 (let ((sym (gensym "")))
62 (print-info pos `(load-program ,sym) #f #f)
63 (lp (+ pos (byte-length asm)) (cdr code)
64 (acons sym asm programs))))
67 (code-annotation end asm objs nargs blocs bexts)
68 (and=> (and srcs (assq end srcs)) source->string))
69 (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
72 (disassemble-externals exts))
74 (disassemble-meta meta))
76 ;; Disassemble other bytecode in it
77 ;; FIXME: something about the module.
82 (begin (display "----------------------------------------\n")
84 (cddr (vector->list objs))))))
86 (error "bad load-program form" asm))))
88 (define (disassemble-objects objs)
89 (display "Objects:\n\n")
90 (let ((len (vector-length objs)))
93 (print-info n (vector-ref objs n) #f #f))))
95 (define (disassemble-externals exts)
96 (display "Externals:\n\n")
97 (let ((len (length exts)))
100 ((null? l) (newline))
101 (print-info n (car l) #f #f))))
103 (define-macro (unless test . body)
104 `(if (not ,test) (begin ,@body)))
106 (define *uninteresting-props* '(name))
108 (define (disassemble-meta meta)
109 (let ((sources (cadr meta))
110 (props (filter (lambda (x)
111 (not (memq (car x) *uninteresting-props*)))
113 (unless (null? props)
114 (display "Properties:\n\n")
115 (for-each (lambda (x) (print-info #f x #f #f)) props)
118 (define (source->string src)
119 (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
120 (source:line src) (source:column src)))
122 (define (make-int16 byte1 byte2)
123 (+ (* byte1 256) byte2))
125 (define (code-annotation end-addr code objs nargs blocs bexts)
126 (let* ((code (assembly-unpack code))
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)
133 (list "-> ~A" (+ end-addr (apply make-int16 args))))
135 (and objs (list "~s" (vector-ref objs (car args)))))
136 ((local-ref local-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 ((external-ref external-set)
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)
155 (let ((v (vector-ref objs (car args))))
156 (if (and (variable? v) (variable-bound? v))
157 (list "~s" (variable-ref v))
160 (list "MV -> ~A" (+ end-addr (apply make-int16 (cdr args)))))
162 (and=> (assembly->object code)
163 (lambda (obj) (list "~s" obj)))))))
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))
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) "..."))))))