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

  ViewVC Help
Powered by ViewVC 1.1.5