1
;; disassembler.jl -- Disassembles compiled Lisp functions
3
;; $Id: disassembler.jl,v 1.53 2000/09/10 20:03:17 john Exp $
5
;; Copyright (C) 1993, 1994 John Harper <john@dcs.warwick.ac.uk>
7
;; This file is part of Jade.
9
;; Jade is free software; you can redistribute it and/or modify it
10
;; under the terms of the GNU General Public License as published by
11
;; the Free Software Foundation; either version 2, or (at your option)
14
;; Jade is distributed in the hope that it will be useful, but
15
;; WITHOUT ANY WARRANTY; without even the implied warranty of
16
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17
;; GNU General Public License for more details.
19
;; You should have received a copy of the GNU General Public License
20
;; along with Jade; see the file COPYING. If not, write to
21
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
23
(declare (unsafe-for-call/cc))
25
(define-structure rep.vm.disassembler
33
(define-structure-alias disassembler rep.vm.disassembler)
35
;; Lookup table of strings naming instructions
36
(define disassembler-opcodes
37
[ "slot-ref" nil nil nil nil nil nil nil ; #x00
38
"call" nil nil nil nil nil nil nil
39
"push" nil nil nil nil nil nil nil ; #x10
40
"refg" nil nil nil nil nil nil nil
41
"setg" nil nil nil nil nil nil nil ; #x20
42
"setn" nil nil nil nil nil nil nil
43
"slot-set" nil nil nil nil nil nil nil ; #x30
44
"refn" nil nil nil nil nil nil nil
45
"ref" "%set" "fluid-ref" "enclose"
46
"init-bind" "unbind" "dup" "swap" ; #x40
47
"pop" "push\t()" "push\tt" "cons"
48
"car" "cdr" "rplaca" "rplacd"
49
"nth" "nthcdr" "aset" "aref"
50
"length" "bind" "add" "neg" "sub" ; #x50
51
"mul" "div" "rem" "lnot" "not" "lor" "land"
52
"equal" "eq" "structure-ref" "scm-test"
53
"gt" "ge" "lt" "le" ; #x60
54
"inc" "dec" "ash" "zerop" "null" "atom" "consp" "listp"
55
"numberp" "stringp" "vectorp" "catch"
56
"throw" "binderr" "return" "unbindall" ; #x70
57
"boundp" "symbolp" "get" "put"
58
"errorpro" "signal" "quotient" "reverse"
59
"nreverse" "assoc" "assq" "rassoc"
60
"rassq" "last" "mapcar" "mapc" ; #x80
61
"member" "memq" "delete" "delq"
62
"delete-if" "delete-if-not" "copy-sequence" "sequencep"
63
"functionp" "special-form-p" "subrp" "eql"
64
"lxor" "max" "min" "filter" ; #x90
65
"macrop" "bytecodep" "pushi\t0" "pushi\t1"
66
"pushi\t2" "pushi\t-1" "pushi\t-2" "pushi\t%d"
67
"pushi\t%d" "pushi\t%d" "caar" "cadr"
68
"cdar" "cddr" "caddr" "cadddr" ; #xa0
69
"caddddr" "cadddddr" "caddddddr" "cadddddddr"
70
"floor" "ceiling" "truncate" "round"
71
"apply" "forbid" "permit" "exp"
72
"log" "sin" "cos" "tan" ; #xb0
73
"sqrt" "expt" "swap2" "mod"
74
"make-closure" "unbindall-0" "closurep" "pop-all"
75
"fluid-set" "fluid-bind" "memql" "num-eq"
76
"test-scm" "test-scm-f" "%define" "spec-bind" ; #xc0
77
"set" "required-arg" "optional-arg" "rest-arg"
78
"not-zero-p" "keyword-arg" "optional-arg*" "keyword-arg*"
79
nil nil nil nil nil nil nil nil ; #xd0
80
nil nil nil nil nil nil nil nil
81
nil nil nil nil nil nil nil nil ; #xe0
82
nil nil nil nil nil nil nil nil
83
nil nil nil nil nil nil nil nil ; #xf0
84
"ejmp\t%d" "jpn\t%d" "jpt\t%d" "jmp\t%d" "jn\t%d" "jt\t%d" "jnp\t%d" "jtp\t%d" ])
86
(defun disassemble-1 (code-string consts stream #!optional depth)
87
(unless depth (setq depth 0))
90
(indent (make-string depth))
92
(while (< i (length code-string))
93
(setq c (aref code-string i))
94
(format stream "\n%s%d\t\t" indent i)
96
((< c (bytecode last-with-args))
97
(setq op (logand c #xf8))
99
((< (logand c #x07) 6)
100
(setq arg (logand c #x07)))
101
((= (logand c #x07) 6)
103
arg (aref code-string i)))
105
(setq arg (logior (ash (aref code-string (1+ i)) 8)
106
(aref code-string (+ i 2)))
109
((= op (bytecode call))
110
(format stream "call\t#%d" arg))
111
((= op (bytecode push))
113
((argobj (aref consts arg)))
114
(if (or (and (consp argobj) (eq (car argobj) 'byte-code))
117
(format stream "push\t[%d] bytecode...\n" arg)
118
(disassemble argobj stream (1+ depth)))
119
(format stream "push\t[%d] %S" arg (aref consts arg)))))
120
((= op (bytecode bind))
121
(format stream "bind\t[%d] %S" arg (aref consts arg)))
122
((= op (bytecode refn))
123
(format stream "refn\t#%d" arg))
124
((= op (bytecode setn))
125
(format stream "setn\t#%d" arg))
126
((= op (bytecode slot-ref))
127
(format stream "slot-ref #%d" arg))
128
((= op (bytecode slot-set))
129
(format stream "slot-set #%d" arg))
130
((= op (bytecode refg))
131
(format stream "refg\t[%d] %S" arg (aref consts arg)))
132
((= op (bytecode setg))
133
(format stream "setg\t[%d] %S" arg (aref consts arg)))))
134
((> c (bytecode last-before-jmps))
135
(setq arg (logior (ash (aref code-string (1+ i)) 8)
136
(aref code-string (+ i 2)))
139
(format stream (aref disassembler-opcodes op) arg))
140
((= c (bytecode pushi))
141
(setq arg (aref code-string (1+ i)))
144
(setq arg (- (- 256 arg))))
145
(format stream (aref disassembler-opcodes c) arg))
146
((or (= c (bytecode pushi-pair-neg))
147
(= c (bytecode pushi-pair-pos)))
148
(setq arg (logior (ash (aref code-string (1+ i)) 8)
149
(aref code-string (+ i 2))))
151
(when (= c (bytecode pushi-pair-neg))
153
(format stream (aref disassembler-opcodes c) arg))
155
(if (setq op (aref disassembler-opcodes c))
157
(format stream "<unknown opcode %d>" c))))
162
(defun disassemble (arg #!optional stream depth)
163
"Dissasembles ARG, with output to STREAM, or the *disassembly* buffer."
164
(interactive "aFunction to disassemble:")
166
(code-string consts stack
171
(declare (bound open-buffer clear-buffer goto-other-view
172
goto-buffer insert start-of-buffer goto))
173
(setq stream (open-buffer "*disassembly*"))
174
(clear-buffer stream)
178
(goto (start-of-buffer))
179
(setq stream (cons stream t)))
180
(setq stream standard-output)))
186
(format stream "Disassembly of function %s:\n\n" arg)
187
(setq arg (symbol-value arg)))
188
(format stream "Disassembly of %S:\n\n" arg)))
190
(setq arg (closure-function arg)))
192
((and (consp arg) (eq (car arg) 'run-byte-code))
193
(setq code-string (nth 1 arg)
197
(setq code-string (aref arg 0)
200
(let ((spec (and (> (length arg) 4) (aref arg 4)))
201
(doc (and (> (length arg) 3) (aref arg 3))))
203
(format stream "Interactive spec: %S\n" spec))
205
(format stream "Doc string: %S\n" doc)))
206
(setq stack (aref arg 2)))))
208
(format stream "%d bytes, %d constants, and (%d,%d,%d) stack slots\n"
209
(length code-string) (length consts)
210
(logand stack #x3ff) (logand (ash stack -10) #x3ff)
212
(disassemble-1 code-string consts stream depth))))
added
removed
lisp/rep/vm/disassembler.jl
