/[cmucl]/src/code/pmax-disassem.lisp
ViewVC logotype

Contents of /src/code/pmax-disassem.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Sun Mar 4 20:12:40 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, sse2-packed-base, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, unicode-string-buffer-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.18: +4 -4 lines
Change most PROCLAIMs to DECLAIMs.
1 ;;; -*- Mode: Lisp; Package: MIPS -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pmax-disassem.lisp,v 1.19 2001/03/04 20:12:40 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; A simple dissambler for the MIPS R2000.
13 ;;;
14 ;;; Written by Christopher Hoover.
15 ;;;
16
17 (in-package "MIPS" :use '("LISP"))
18
19 (export '(register-name disassemble-code-vector))
20
21
22 ;;;; Instruction Layout
23
24 ;;;
25 ;;; Each instrunction on the MIPS R2000 consists of a single word (32
26 ;;; bits) aligned on a single word boundaray. There are three
27 ;;; instrunction formats:
28 ;;;
29 ;;; I-Type (Immediate)
30 ;;;
31 ;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0
32 ;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
33 ;;; ---------------------------------------------------------------
34 ;;; [ op ] [ rs ] [ rt ] [ immediate ]
35 ;;; ---------------------------------------------------------------
36 ;;;
37 ;;;
38 ;;; J-Type (Jump)
39 ;;;
40 ;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0
41 ;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
42 ;;; ---------------------------------------------------------------
43 ;;; [ op ] [ target ]
44 ;;; ---------------------------------------------------------------
45 ;;;
46 ;;;
47 ;;; R-Type (Register)
48 ;;;
49 ;;; 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0
50 ;;; 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
51 ;;; ---------------------------------------------------------------
52 ;;; [ op ] [ rs ] [ rt ] [ rd ] [ shmat ] [ funct ]
53 ;;; ---------------------------------------------------------------
54 ;;;
55 ;;; These instructions fall into 5 categories: Load/Store,
56 ;;; Computational, Jump/Branch, Coprocessor, and Special.
57 ;;;
58
59
60 ;;;; Register Names
61
62 (defun register-name (register-number)
63 (unless (<= 0 register-number 31)
64 (error "Illegal register number!"))
65 (svref *register-names* register-number))
66
67
68
69 ;;;; Instruction Type Definition
70
71 ;;;
72 ;;; These instruction types correspond to the various ways the decoded
73 ;;; instructions are printed which in turn corresponds somewhat to the
74 ;;; way the instructions are decoded.
75 ;;;
76
77 (defvar *mips-instruction-types* (make-hash-table :test #'eq))
78
79 (defmacro def-mips-instruction-type (types &body body)
80 `(let ((closure #'(lambda (name word stream) ,@body)))
81 (dolist (type ',types)
82 (when (gethash type *mips-instruction-types*)
83 (warn "Instruction type ~S being redefined" type))
84 (setf (gethash type *mips-instruction-types*) closure))))
85
86 (defun mips-instruction-type-p (type)
87 (not (not (gethash type *mips-instruction-types*))))
88
89
90 ;;;; Instruction Types
91
92 ;;;
93 ;;; Used later for relative branches.
94 (defvar *current-instruction-number* 0)
95
96 (def-mips-instruction-type (:ls-type)
97 (let ((rs (ldb (byte 5 21) word))
98 (rt (ldb (byte 5 16) word))
99 (immed (signed-ldb (byte 16 0) word)))
100 (format stream "~16,8T~A~8,8T~A, #x~X(~A)~%"
101 name (register-name rt) immed (register-name rs))))
102
103 (def-mips-instruction-type (:si-type)
104 (let ((rs (ldb (byte 5 21) word))
105 (rt (ldb (byte 5 16) word))
106 (immed (signed-ldb (byte 16 0) word)))
107 (cond ((and (zerop rs) (or (string= name "ADDI") (string= name "ADDIU")))
108 (format stream "~16,8TLOADI~8,8T~A, #x~X~%"
109 (register-name rt) immed))
110 ((and (= rs null-offset) (string= name "ADDI"))
111 ;; Major hack ...
112 (format stream "~16,8T~A~8,8T~A, ~A, #x~X~48,8T; ~S~%"
113 name (register-name rt) (register-name rs) immed
114 (vm:offset-static-symbol immed)))
115 (t
116 (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
117 name (register-name rt) (register-name rs) immed)))))
118
119 (def-mips-instruction-type (:ui-type)
120 (let ((rs (ldb (byte 5 21) word))
121 (rt (ldb (byte 5 16) word))
122 (immed (ldb (byte 16 0) word)))
123 (cond ((and (zerop rs) (or (string= name "ORI") (string= name "XORI")))
124 (format stream "~16,8TLOADI~8,8T~A, #x~X~%"
125 (register-name rt) immed))
126 (t
127 (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
128 name (register-name rt) (register-name rs) immed)))))
129
130 (def-mips-instruction-type (:lui-type)
131 (let ((rt (ldb (byte 5 16) word))
132 (immed (ldb (byte 16 0) word)))
133 (format stream "~16,8T~A~8,8T~A, #x~X~%" name (register-name rt) immed)))
134
135 (def-mips-instruction-type (:j-type)
136 (let ((target (ldb (byte 26 0) word)))
137 (format stream "~16,8T~A~8,8Ttarget = ~D~%" name target)))
138
139 (def-mips-instruction-type (:jr-type)
140 (let ((rs (ldb (byte 5 21) word)))
141 (format stream "~16,8T~A~8,8T~A~%" name (register-name rs))))
142
143 (def-mips-instruction-type (:jalr-type)
144 (let ((rs (ldb (byte 5 21) word))
145 (rd (ldb (byte 5 11) word)))
146 (format stream "~16,8T~A~8,8T~A, ~A~%" name
147 (register-name rd) (register-name rs))))
148
149 (defun branch-target (offset)
150 (+ *current-instruction-number* offset 1))
151
152 (def-mips-instruction-type (:branch-type)
153 (let ((rs (ldb (byte 5 21) word))
154 (offset (signed-ldb (byte 16 0) word)))
155 (format stream "~16,8T~A~8,8T~A, ~D~%" name
156 (register-name rs) (branch-target offset))))
157
158 (def-mips-instruction-type (:branch2-type)
159 (let* ((rs (ldb (byte 5 21) word))
160 (rt (ldb (byte 5 16) word))
161 (offset (signed-ldb (byte 16 0) word))
162 (target (branch-target offset)))
163 (cond ((and (zerop rs) (zerop rt) (string= name "BEQ"))
164 (format stream "~16,8TB~8,8T~D~%" target))
165 (t
166 (format stream "~16,8T~A~8,8T~A, ~A, ~D~%" name
167 (register-name rs) (register-name rt) target)))))
168
169 (def-mips-instruction-type (:r3-type)
170 (let ((rs (ldb (byte 5 21) word))
171 (rt (ldb (byte 5 16) word))
172 (rd (ldb (byte 5 11) word)))
173 (cond ((zerop rd)
174 ;; Hack for NOP
175 (format stream "~16,8TNOP~%"))
176 ((and (zerop rt) (or (string= name "OR") (string= name "ADDU")))
177 ;; Hack for MOVE
178 (format stream "~16,8TMOVE~8,8T~A, ~A~%"
179 (register-name rd) (register-name rs)))
180 (t
181 (format stream "~16,8T~A~8,8T~A, ~A, ~A~%"
182 name (register-name rd) (register-name rs)
183 (register-name rt))))))
184
185 (def-mips-instruction-type (:mf-type)
186 (let ((rd (ldb (byte 5 11) word)))
187 (format stream "~16,8T~A~8,8T~A~%" name (register-name rd))))
188
189 (def-mips-instruction-type (:mt-type)
190 (let ((rs (ldb (byte 5 21) word)))
191 (format stream "~16,8T~A~8,8T~A~%" name (register-name rs))))
192
193 (def-mips-instruction-type (:mult-type)
194 (let ((rs (ldb (byte 5 21) word))
195 (rt (ldb (byte 5 16) word)))
196 (format stream "~16,8T~A~8,8T~A, ~A~%" name
197 (register-name rs) (register-name rt))))
198
199 (def-mips-instruction-type (:shift-type)
200 (let ((rt (ldb (byte 5 16) word))
201 (rd (ldb (byte 5 11) word))
202 (shamt (ldb (byte 5 6) word)))
203 ;; Hack for NOP
204 (cond ((= word 0)
205 (format stream "~16,8TNOP~%"))
206 (t
207 (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
208 name (register-name rd) (register-name rt) shamt)))))
209
210 (def-mips-instruction-type (:shiftv-type)
211 (let ((rs (ldb (byte 5 21) word))
212 (rt (ldb (byte 5 16) word))
213 (rd (ldb (byte 5 11) word)))
214 (format stream "~16,8T~A~8,8T~A, ~A, ~A~%"
215 name (register-name rd) (register-name rt) (register-name rs))))
216
217 (def-mips-instruction-type (:break-type)
218 (let ((code (ldb (byte 10 16) word))) ; The entire field is (byte 20 6)
219 (format stream "~16,8T~A~8,8T#x~X~%" name code)))
220
221 (def-mips-instruction-type (:syscall-type)
222 (declare (ignore word))
223 (format stream "~16,8T~A~%" name))
224
225 (def-mips-instruction-type (:cop0-type :cop1-type :cop2-type :cop3-type)
226 (format stream "~16,8T~A~8,8T(#x~X)~%" name word))
227
228
229 ;;;; Instruction Definition
230
231 (defstruct (mips-instruction
232 (:constructor make-mips-instruction (name type))
233 (:print-function %print-mips-instruction))
234 (name "" :type simple-string)
235 type)
236
237 (defun %print-mips-instruction (instr stream depth)
238 (declare (ignore depth))
239 (format stream "#<MIPS instruction ~A>" (mips-instruction-name instr)))
240
241
242 (defconstant mips-instruction-bits 6)
243
244 (defvar *mips-instructions*
245 (make-array (ash 1 mips-instruction-bits) :initial-element nil))
246 (declaim (type simple-vector *mips-instructions*))
247
248 (defmacro def-mips-instr (name op-code type)
249 `(let ((name ,name)
250 (type ,type))
251 (unless (mips-instruction-type-p type)
252 (warn "~S is an unknown instruction type" type))
253 (setf (svref *mips-instructions* ,op-code)
254 (make-mips-instruction name ,type))
255 name))
256
257
258 (defconstant mips-special-instruction-bits 6)
259
260 (defvar *mips-special-instructions*
261 (make-array (ash 1 mips-special-instruction-bits) :initial-element nil))
262 (declaim (type simple-vector *mips-special-instructions*))
263
264 (defmacro def-mips-special-instr (name op-code type)
265 `(let ((name ,name)
266 (type ,type))
267 (unless (mips-instruction-type-p type)
268 (warn "~S is an unknown instruction type" type))
269 (setf (svref *mips-special-instructions* ,op-code)
270 (make-mips-instruction name ,type))
271 name))
272
273
274 (defconstant mips-bcond-instruction-bits 6)
275
276 (defvar *mips-bcond-instructions*
277 (make-array (ash 1 mips-bcond-instruction-bits) :initial-element nil))
278 (declaim (type simple-vector *mips-bcond-instructions*))
279
280 (defmacro def-mips-bcond-instr (name op-code type)
281 `(let ((name ,name)
282 (type ,type))
283 (unless (mips-instruction-type-p type)
284 (warn "~S is an unknown instruction type" type))
285 (setf (svref *mips-bcond-instructions* ,op-code)
286 (make-mips-instruction name ,type))
287 name))
288
289
290 ;;;; Normal Opcodes
291
292 (def-mips-instr "J" #b000010 :j-type)
293 (def-mips-instr "JAL" #b000011 :j-type)
294 (def-mips-instr "BEQ" #b000100 :branch2-type)
295 (def-mips-instr "BNE" #b000101 :branch2-type)
296 (def-mips-instr "BLEZ" #b000110 :branch-type)
297 (def-mips-instr "BGTZ" #b000111 :branch-type)
298
299 (def-mips-instr "ADDI" #b001000 :si-type)
300 (def-mips-instr "ADDIU" #b001001 :si-type)
301 (def-mips-instr "SLTI" #b001010 :si-type)
302 (def-mips-instr "SLTIU" #b001011 :si-type)
303 (def-mips-instr "ANDI" #b001100 :ui-type)
304 (def-mips-instr "ORI" #b001101 :ui-type)
305 (def-mips-instr "XORI" #b001110 :ui-type)
306 (def-mips-instr "LUI" #b001111 :lui-type)
307
308 (def-mips-instr "COP0" #b010000 :cop0-type)
309 (def-mips-instr "COP1" #b010001 :cop1-type)
310 (def-mips-instr "COP2" #b010010 :cop2-type)
311 (def-mips-instr "COP3" #b010011 :cop3-type)
312
313 (def-mips-instr "LB" #b100000 :ls-type)
314 (def-mips-instr "LH" #b100001 :ls-type)
315 (def-mips-instr "LWL" #b100010 :ls-type)
316 (def-mips-instr "LW" #b100011 :ls-type)
317 (def-mips-instr "LBU" #b100100 :ls-type)
318 (def-mips-instr "LHU" #b100101 :ls-type)
319 (def-mips-instr "LWR" #b100110 :ls-type)
320
321 (def-mips-instr "SB" #b101000 :ls-type)
322 (def-mips-instr "SH" #b101001 :ls-type)
323 (def-mips-instr "SWL" #b101010 :ls-type)
324 (def-mips-instr "SW" #b101011 :ls-type)
325 (def-mips-instr "SWR" #b101110 :ls-type)
326
327 (def-mips-instr "LWC0" #b110000 :cop0-type)
328 (def-mips-instr "LWC1" #b110001 :cop1-type)
329 (def-mips-instr "LWC2" #b110010 :cop2-type)
330 (def-mips-instr "LWC3" #b110011 :cop3-type)
331
332 (def-mips-instr "SWC0" #b111000 :cop0-type)
333 (def-mips-instr "SWC1" #b111001 :cop1-type)
334 (def-mips-instr "SWC2" #b111010 :cop2-type)
335 (def-mips-instr "SWC3" #b111011 :cop3-type)
336
337
338 ;;;; SPECIAL Opcodes
339
340 (defconstant special-op #b000000)
341
342 (def-mips-special-instr "SLL" #b000000 :shift-type)
343 (def-mips-special-instr "SRL" #b000010 :shift-type)
344 (def-mips-special-instr "SRA" #b000011 :shift-type)
345 (def-mips-special-instr "SLLV" #b000100 :shiftv-type)
346 (def-mips-special-instr "SRLV" #b000110 :shiftv-type)
347 (def-mips-special-instr "SRAV" #b000111 :shiftv-type)
348
349 (def-mips-special-instr "JR" #b001000 :jr-type)
350 (def-mips-special-instr "JALR" #b001001 :jalr-type)
351 (def-mips-special-instr "SYSCALL" #b001100 :syscall-type)
352 (def-mips-special-instr "BREAK" #b001101 :break-type)
353
354 (def-mips-special-instr "MFHI" #b010000 :mf-type)
355 (def-mips-special-instr "MTHI" #b010001 :mt-type)
356 (def-mips-special-instr "MFLO" #b010010 :mf-type)
357 (def-mips-special-instr "MTLO" #b010011 :mt-type)
358
359 (def-mips-special-instr "MULT" #b011000 :mult-type)
360 (def-mips-special-instr "MULTU" #b011001 :mult-type)
361 (def-mips-special-instr "DIV" #b011010 :mult-type)
362 (def-mips-special-instr "DIVU" #b011011 :mult-type)
363
364 (def-mips-special-instr "ADD" #b100000 :r3-type)
365 (def-mips-special-instr "ADDU" #b100001 :r3-type)
366 (def-mips-special-instr "SUB" #b100010 :r3-type)
367 (def-mips-special-instr "SUBU" #b100011 :r3-type)
368 (def-mips-special-instr "AND" #b100100 :r3-type)
369 (def-mips-special-instr "OR" #b100101 :r3-type)
370 (def-mips-special-instr "XOR" #b100110 :r3-type)
371 (def-mips-special-instr "NOR" #b100111 :r3-type)
372
373 (def-mips-special-instr "SLT" #b101010 :r3-type)
374 (def-mips-special-instr "SLTU" #b101011 :r3-type)
375
376
377 ;;;; BCOND Opcodes
378
379 (defconstant bcond-op #b000001)
380
381 (def-mips-bcond-instr "BLTZ" #b00000 :branch-type)
382 (def-mips-bcond-instr "BLTZAL" #b00001 :branch-type)
383
384 (def-mips-bcond-instr "BLTZAL" #b10000 :branch-type)
385 (def-mips-bcond-instr "BGEZAL" #b10001 :branch-type)
386
387
388 ;;;; Signed-Ldb
389
390 (defun signed-ldb (byte-spec integer)
391 (let ((unsigned (ldb byte-spec integer))
392 (length (byte-size byte-spec)))
393 (if (logbitp (1- length) unsigned)
394 (- unsigned (ash 1 length))
395 unsigned)))
396
397
398 ;;;; Instruction Decoding
399
400 (defun mips-instruction (word)
401 (let* ((opcode (ldb (byte 6 26) word)))
402 (cond ((= opcode special-op)
403 (let ((function (ldb (byte 6 0) word)))
404 (svref *mips-special-instructions* function)))
405 ((= opcode bcond-op)
406 (let ((cond (ldb (byte 5 16) word)))
407 (svref *mips-bcond-instructions* cond)))
408 (t
409 (svref *mips-instructions* opcode)))))
410
411
412 ;;;; Disassemble-Instruction
413
414 (defun disassemble-instruction (word &optional (stream t))
415 (let* ((instr (mips-instruction word)))
416 (cond (instr
417 (let* ((instr-name (mips-instruction-name instr))
418 (instr-type (mips-instruction-type instr))
419 (closure (gethash instr-type *mips-instruction-types*)))
420 (cond (closure
421 (funcall closure instr-name word stream))
422 (t
423 (format stream "UNKNOWN TYPE (~A/~S/#x~X)~%"
424 instr-name instr-type word)))
425 (values instr-name instr-type)))
426 (t
427 (format stream "~16,8TDATA~8,8T#x~X~%" word)
428 (return-from disassemble-instruction (values nil nil))))))
429
430
431
432 ;;; Dissassemble-Code-Vector
433
434 (defconstant delay-slot-instruction-types
435 '(:j-type :jr-type :jalr-type :branch-type :branch2-type))
436
437 (defun disassemble-code-vector (code-vector length &optional (stream t))
438 (do ((i 0 (+ i 4))
439 (*current-instruction-number* 0 (1+ *current-instruction-number*))
440 (instruction-in-delay-slot-p nil))
441 ((>= i length))
442 (unless instruction-in-delay-slot-p
443 (format stream "~6D:" *current-instruction-number*))
444 (multiple-value-bind
445 (name type)
446 (disassemble-instruction (logior (aref code-vector i)
447 (ash (aref code-vector (+ i 1)) 8)
448 (ash (aref code-vector (+ i 2)) 16)
449 (ash (aref code-vector (+ i 3)) 24))
450 stream)
451 (declare (ignore name))
452 (cond ((member type delay-slot-instruction-types :test #'eq)
453 (setf instruction-in-delay-slot-p t))
454 (t
455 (setf instruction-in-delay-slot-p nil))))))
456
457
458
459 ;;;; Disassemble-code-sap
460
461 (defun disassemble-code-sap (sap length &optional (stream t))
462 (do ((*current-instruction-number* 0 (1+ *current-instruction-number*))
463 (instruction-in-delay-slot-p nil))
464 ((>= *current-instruction-number* length))
465 (unless instruction-in-delay-slot-p
466 (format stream "~6D:" *current-instruction-number*))
467 (multiple-value-bind
468 (name type)
469 (disassemble-instruction (system:sap-ref-32
470 sap
471 *current-instruction-number*)
472 stream)
473 (declare (ignore name))
474 (cond ((member type delay-slot-instruction-types :test #'eq)
475 (setf instruction-in-delay-slot-p t))
476 (t
477 (setf instruction-in-delay-slot-p nil))))))
478
479
480 ;;;; Disassemble
481
482 (defun compile-function-lambda-expr (function)
483 (multiple-value-bind
484 (lambda closurep name)
485 (function-lambda-expression function)
486 (declare (ignore name))
487 (when closurep
488 (error "Cannot compile lexical closure."))
489 (compile nil lambda)))
490
491 (defun disassemble (object &optional (stream *standard-output*))
492 (let* ((function (cond ((or (symbolp object)
493 (and (listp object)
494 (eq (car object) 'lisp:setf)))
495 (let ((temp (fdefinition object)))
496 (if (eval:interpreted-function-p temp)
497 (compile-function-lambda-expr temp)
498 temp)))
499 ((eval:interpreted-function-p object)
500 (compile-function-lambda-expr object))
501 ((functionp object)
502 object)
503 ((and (listp object)
504 (eq (car object) 'lisp::lambda))
505 (compile nil object))
506 (t
507 (error "Invalid argument to disassemble - ~S"
508 object))))
509 (self (system:%primitive function-self function))
510 (code (di::function-code-header self)))
511 (disassemble-code-sap (truly-the system:system-area-pointer
512 (system:%primitive code-instructions
513 code))
514 (system:%primitive code-code-size code)
515 stream)))

  ViewVC Help
Powered by ViewVC 1.1.5