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

  ViewVC Help
Powered by ViewVC 1.1.5