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) | |
23 | :use-module (system vm core) | |
24 | :use-module (system vm conv) | |
25 | :use-module (ice-9 regex) | |
26 | :use-module (ice-9 match) | |
27 | :use-module (ice-9 format) | |
28 | :use-module (ice-9 receive) | |
29 | :use-module (ice-9 and-let-star) | |
58995613 | 30 | :export (disassemble-dumpcode disassemble-program)) |
4bfb26f5 | 31 | |
58995613 KN |
32 | (define (disassemble-dumpcode dumpcode . opts) |
33 | (if (not (dumpcode? dumpcode)) (error "Invalid dumpcode")) | |
34 | (format #t "Disassembly of dumpcode:\n\n") | |
35 | (format #t "Compiled for Guile VM ~A\n\n" (dumpcode-version dumpcode)) | |
4bfb26f5 | 36 | (format #t "nlocs = ~A nexts = ~A\n\n" |
58995613 KN |
37 | (dumpcode-nlocs dumpcode) (dumpcode-nexts dumpcode)) |
38 | (disassemble-bytecode (dumpcode-bytecode dumpcode) #f)) | |
17e90c5e KN |
39 | |
40 | (define (disassemble-program prog . opts) | |
41 | (let* ((arity (program-arity prog)) | |
42 | (nargs (car arity)) | |
43 | (nrest (cadr arity)) | |
44 | (nlocs (caddr arity)) | |
4bfb26f5 | 45 | (nexts (cadddr arity)) |
17e90c5e | 46 | (bytes (program-bytecode prog)) |
41f248a8 KN |
47 | (objs (program-objects prog)) |
48 | (exts (program-external prog))) | |
17e90c5e KN |
49 | ;; Disassemble this bytecode |
50 | (format #t "Disassembly of ~A:\n\n" prog) | |
3616e9e9 | 51 | (format #t "nargs = ~A nrest = ~A nlocs = ~A nexts = ~A\n\n" |
4bfb26f5 | 52 | nargs nrest nlocs nexts) |
17e90c5e KN |
53 | (format #t "Bytecode:\n\n") |
54 | (disassemble-bytecode bytes objs) | |
55 | (if (> (vector-length objs) 0) | |
56 | (disassemble-objects objs)) | |
41f248a8 KN |
57 | (if (pair? exts) |
58 | (disassemble-externals exts)) | |
17e90c5e KN |
59 | ;; Disassemble other bytecode in it |
60 | (for-each | |
61 | (lambda (x) | |
62 | (if (program? x) | |
63 | (begin (display "----------------------------------------\n") | |
64 | (apply disassemble-program x opts)))) | |
65 | (vector->list objs)))) | |
66 | ||
4bfb26f5 | 67 | (define (disassemble-bytecode bytes objs) |
17e90c5e | 68 | (let ((decode (make-byte-decoder bytes)) |
58995613 | 69 | (programs '())) |
17e90c5e KN |
70 | (do ((addr+code (decode) (decode))) |
71 | ((not addr+code) (newline)) | |
72 | (receive (addr code) addr+code | |
73 | (match code | |
74 | (('load-program x) | |
75 | (let ((sym (gensym ""))) | |
58995613 | 76 | (set! programs (acons sym x programs)) |
17e90c5e KN |
77 | (print-info addr (format #f "load-program #~A" sym) #f))) |
78 | (else | |
a80be762 | 79 | (let ((info (list->info code)) |
4bfb26f5 | 80 | (extra (original-value addr code objs))) |
17e90c5e KN |
81 | (print-info addr info extra)))))) |
82 | (for-each (lambda (sym+bytes) | |
83 | (format #t "Bytecode #~A:\n\n" (car sym+bytes)) | |
4bfb26f5 | 84 | (disassemble-bytecode (cdr sym+bytes) #f)) |
58995613 | 85 | (reverse! programs)))) |
17e90c5e KN |
86 | |
87 | (define (disassemble-objects objs) | |
88 | (display "Objects:\n\n") | |
89 | (let ((len (vector-length objs))) | |
90 | (do ((n 0 (1+ n))) | |
91 | ((= n len) (newline)) | |
92 | (let ((info (object->string (vector-ref objs n)))) | |
93 | (print-info n info #f))))) | |
94 | ||
41f248a8 KN |
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 | (let ((info (object->string (car l)))) | |
102 | (print-info n info #f))))) | |
103 | ||
17e90c5e KN |
104 | (define (disassemble-meta meta) |
105 | (display "Meta info:\n\n") | |
106 | (for-each (lambda (data) | |
a80be762 | 107 | (print-info (car data) (list->info (cdr data)) #f)) |
17e90c5e KN |
108 | meta) |
109 | (newline)) | |
110 | ||
46cd9a34 | 111 | (define (original-value addr code objs) |
17e90c5e | 112 | (define (branch-code? code) |
41f248a8 | 113 | (string-match "^br" (symbol->string (car code)))) |
17e90c5e KN |
114 | (let ((code (code-unpack code))) |
115 | (cond ((code->object code) => object->string) | |
46cd9a34 | 116 | ((branch-code? code) |
41f248a8 KN |
117 | (let ((offset (+ (* (cadr code) 256) (caddr code)))) |
118 | (format #f "-> ~A" (+ addr offset 3)))) | |
17e90c5e KN |
119 | (else |
120 | (let ((inst (car code)) (args (cdr code))) | |
121 | (case inst | |
122 | ((make-false) "#f") | |
46cd9a34 KN |
123 | ((object-ref) |
124 | (if objs (object->string (vector-ref objs (car args))) #f)) | |
17e90c5e KN |
125 | (else #f))))))) |
126 | ||
a80be762 | 127 | (define (list->info list) |
17e90c5e KN |
128 | (let ((str (object->string list))) |
129 | (substring str 1 (1- (string-length str))))) | |
130 | ||
131 | (define (print-info addr info extra) | |
132 | (if extra | |
46cd9a34 | 133 | (format #t "~4@A ~32A;; ~A\n" addr info extra) |
17e90c5e | 134 | (format #t "~4@A ~A\n" addr info))) |