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

  ViewVC Help
Powered by ViewVC 1.1.5