/[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.8 - (hide annotations)
Sun Feb 18 06:23:22 1990 UTC (24 years, 2 months ago) by ch
Branch: MAIN
Changes since 1.7: +9 -2 lines
Fixed printing of MOVE pseudo-instruction.

Added ugly hack to print out a comment when loading symbol constants.
1 ch 1.1 ;;; -*- Mode: Lisp; Package: MIPS -*-
2     ;;;
3 ch 1.8 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/pmax-disassem.lisp,v 1.8 1990/02/18 06:23:22 ch Exp $
4 wlott 1.2 ;;;
5 ch 1.1 ;;; A simple dissambler for the MIPS R2000.
6     ;;;
7     ;;; Written by Christopher Hoover.
8     ;;;
9    
10     (in-package "MIPS" :use '("LISP"))
11 wlott 1.6
12     (export '(register-name disassemble-code-vector))
13 ch 1.1
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 wlott 1.2 (defparameter register-name-style :lisp
56 ch 1.1 "The register name style: :c, :lisp, :raw")
57    
58     (defvar *c-register-names*
59 ch 1.4 '#("ZERO" "$AT" "$V0" "$V1" "$A0" "$A1" "$A2" "$A3"
60     "$T0" "$T1" "$T2" "$T3" "$T4" "$T5" "$T6" "$T7"
61     "$S0" "$S1" "$S2" "$S3" "$S4" "$S5" "$S6" "$S7"
62     "$T8" "$T9" "$K0" "$K1" "$GP" "$SP" "$S8" "$RA"))
63 ch 1.1
64     (defvar *lisp-register-names*
65 wlott 1.7 '#("$ZERO" "$LIP" "$NL0" "$NL1" "$NL2" "$NL3" "$NL4" "$NARGS"
66     "$A0" "$A1" "$A2" "$A3" "$A4" "$A5" "$CNAME" "$LEXENV"
67     "$ARGS" "$OLDCONT" "$LRA" "$L0" "$NULL" "$BSP" "$CONT" "$CSP"
68     "$FLAGS" "$ALLOC" "$K0" "$K1" "$L1" "$NSP" "$CODE" "$L2"))
69 ch 1.1
70     (defvar *raw-register-names*
71 ch 1.4 '#("$R0" "$R1" "$R2" "$R3" "$R4" "$R5" "$R6" "$R7"
72     "$R8" "$R9" "$R10" "$R12" "$R13" "$R14" "$R15"
73     "$R16" "$R17" "$R18" "$R19" "$R20" "$R21" "$R22" "$R23"
74     "$R24" "$R25" "$R26" "$R27" "$R28" "$R29" "$R30" "$R31"))
75 ch 1.1
76     (defun register-name (register-number)
77     (unless (<= 0 register-number 31)
78     (error "Illegal register number!"))
79     (let ((register-names (ecase register-name-style
80 ch 1.5 (:c *c-register-names*)
81     (:lisp *lisp-register-names*)
82     (:raw *raw-register-names*))))
83 ch 1.1 (svref register-names register-number)))
84    
85    
86     ;;;; Instruction Type Definition
87    
88     ;;;
89     ;;; These instruction types correspond to the various ways the decoded
90     ;;; instructions are printed which in turn corresponds somewhat to the
91     ;;; way the instructions are decoded.
92     ;;;
93    
94     (defvar *mips-instruction-types* (make-hash-table :test #'eq))
95    
96     (defmacro def-mips-instruction-type (types &body body)
97     `(let ((closure #'(lambda (name word stream) ,@body)))
98     (dolist (type ',types)
99     (when (gethash type *mips-instruction-types*)
100     (warn "Instruction type ~S being redefined" type))
101 ch 1.4 (setf (gethash type *mips-instruction-types*) closure))))
102 ch 1.1
103     (defun mips-instruction-type-p (type)
104     (not (not (gethash type *mips-instruction-types*))))
105    
106    
107     ;;;; Instruction Types
108    
109 ch 1.4 ;;;
110     ;;; Used later for relative branches.
111     (defvar *current-instruction-number* 0)
112    
113 ch 1.1 (def-mips-instruction-type (:ls-type)
114     (let ((rs (ldb (byte 5 21) word))
115     (rt (ldb (byte 5 16) word))
116     (immed (signed-ldb (byte 16 0) word)))
117 ch 1.4 (format stream "~16,8T~A~8,8T~A, #x~X(~A)~%"
118 ch 1.1 name (register-name rt) immed (register-name rs))))
119    
120     (def-mips-instruction-type (:si-type)
121     (let ((rs (ldb (byte 5 21) word))
122     (rt (ldb (byte 5 16) word))
123     (immed (signed-ldb (byte 16 0) word)))
124 ch 1.5 (cond ((and (zerop rs) (or (string= name "ADDI") (string= name "ADDIU")))
125     (format stream "~16,8TLOADI~8,8T~A, #x~X~%"
126     (register-name rt) immed))
127 ch 1.8 ;; I'm not proud of this ...
128     ((and (= rs c::null-offset) (string= name "ADDI")
129     (eq register-name-style :lisp))
130     (format stream "~16,8T~A~8,8T~A, ~A, #x~X~48,8T; ~S~%"
131     name (register-name rt) (register-name rs) immed
132     (nth (1- (floor immed vm:symbol-size))
133     vm:initial-symbols)))
134 ch 1.5 (t
135     (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
136     name (register-name rt) (register-name rs) immed)))))
137 ch 1.1
138     (def-mips-instruction-type (:ui-type)
139     (let ((rs (ldb (byte 5 21) word))
140     (rt (ldb (byte 5 16) word))
141     (immed (ldb (byte 16 0) word)))
142 ch 1.5 (cond ((and (zerop rs) (or (string= name "ORI") (string= name "XORI")))
143     (format stream "~16,8TLOADI~8,8T~A, #x~X~%"
144     (register-name rt) immed))
145     (t
146     (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
147     name (register-name rt) (register-name rs) immed)))))
148 ch 1.1
149     (def-mips-instruction-type (:lui-type)
150     (let ((rt (ldb (byte 5 16) word))
151     (immed (ldb (byte 16 0) word)))
152 ch 1.4 (format stream "~16,8T~A~8,8T~A, #x~X~%" name (register-name rt) immed)))
153 ch 1.1
154     (def-mips-instruction-type (:j-type)
155     (let ((target (ldb (byte 26 0) word)))
156 ch 1.4 (format stream "~16,8T~A~8,8Ttarget = ~D~%" name target)))
157 ch 1.1
158     (def-mips-instruction-type (:jr-type)
159     (let ((rs (ldb (byte 5 21) word)))
160 ch 1.4 (format stream "~16,8T~A~8,8T~A~%" name (register-name rs))))
161 ch 1.1
162     (def-mips-instruction-type (:jalr-type)
163     (let ((rs (ldb (byte 5 21) word))
164     (rd (ldb (byte 5 11) word)))
165 ch 1.4 (format stream "~16,8T~A~8,8T~A, ~A~%" name
166     (register-name rd) (register-name rs))))
167 ch 1.1
168 ch 1.4 (defun branch-target (offset)
169     (+ *current-instruction-number* offset 1))
170    
171 ch 1.1 (def-mips-instruction-type (:branch-type)
172     (let ((rs (ldb (byte 5 21) word))
173 ch 1.4 (offset (signed-ldb (byte 16 0) word)))
174     (format stream "~16,8T~A~8,8T~A, ~D~%" name
175     (register-name rs) (branch-target offset))))
176 ch 1.1
177     (def-mips-instruction-type (:branch2-type)
178 ch 1.5 (let* ((rs (ldb (byte 5 21) word))
179     (rt (ldb (byte 5 16) word))
180     (offset (signed-ldb (byte 16 0) word))
181     (target (branch-target offset)))
182     (cond ((and (zerop rs) (zerop rt) (string= name "BEQ"))
183     (format stream "~16,8TB~8,8T~D~%" target))
184     (t
185     (format stream "~16,8T~A~8,8T~A, ~A, ~D~%" name
186     (register-name rs) (register-name rt) target)))))
187 ch 1.1
188     (def-mips-instruction-type (:r3-type)
189     (let ((rs (ldb (byte 5 21) word))
190     (rt (ldb (byte 5 16) word))
191     (rd (ldb (byte 5 11) word)))
192 wlott 1.2 (cond ((zerop rd)
193     ;; Hack for NOP
194 ch 1.4 (format stream "~16,8TNOP~%"))
195 ch 1.8 ((and (zerop rt) (or (string= name "OR") (string= name "ADDU")))
196 wlott 1.2 ;; Hack for MOVE
197 ch 1.4 (format stream "~16,8TMOVE~8,8T~A, ~A~%"
198 wlott 1.2 (register-name rd) (register-name rs)))
199     (t
200 ch 1.4 (format stream "~16,8T~A~8,8T~A, ~A, ~A~%"
201 wlott 1.2 name (register-name rd) (register-name rs)
202     (register-name rt))))))
203 ch 1.1
204     (def-mips-instruction-type (:mf-type)
205     (let ((rd (ldb (byte 5 11) word)))
206 ch 1.4 (format stream "~16,8T~A~8,8T~A~%" name (register-name rd))))
207 ch 1.1
208     (def-mips-instruction-type (:mt-type)
209     (let ((rs (ldb (byte 5 21) word)))
210 ch 1.4 (format stream "~16,8T~A~8,8T~A~%" name (register-name rs))))
211 ch 1.1
212     (def-mips-instruction-type (:mult-type)
213     (let ((rs (ldb (byte 5 21) word))
214     (rt (ldb (byte 5 16) word)))
215 ch 1.4 (format stream "~16,8T~A~8,8T~A, ~A~%" name
216     (register-name rs) (register-name rt))))
217 ch 1.1
218     (def-mips-instruction-type (:shift-type)
219     (let ((rt (ldb (byte 5 16) word))
220     (rd (ldb (byte 5 11) word))
221     (shamt (ldb (byte 5 6) word)))
222     ;; Hack for NOP
223     (cond ((= word 0)
224 ch 1.4 (format stream "~16,8TNOP~%"))
225 ch 1.1 (t
226 ch 1.4 (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
227 ch 1.1 name (register-name rd) (register-name rt) shamt)))))
228    
229     (def-mips-instruction-type (:shiftv-type)
230     (let ((rs (ldb (byte 5 21) word))
231     (rt (ldb (byte 5 16) word))
232     (rd (ldb (byte 5 11) word)))
233 ch 1.4 (format stream "~16,8T~A~8,8T~A, ~A, ~A~%"
234 ch 1.1 name (register-name rd) (register-name rt) (register-name rs))))
235    
236     (def-mips-instruction-type (:break-type)
237 wlott 1.3 (let ((code (ldb (byte 20 6) word))) ; sandro's adb uses (byte 10 16)
238 ch 1.4 (format stream "~16,8T~A~8,8T#x~X~%" name code)))
239 ch 1.1
240     (def-mips-instruction-type (:syscall-type)
241     (declare (ignore word))
242 ch 1.4 (format stream "~16,8T~A~%" name))
243 ch 1.1
244     (def-mips-instruction-type (:cop0-type :cop1-type :cop2-type :cop3-type)
245 ch 1.4 (format stream "~16,8T~A~8,8T(#x~X)~%" name word))
246 ch 1.1
247    
248     ;;;; Instruction Definition
249    
250     (defstruct (mips-instruction
251     (:constructor make-mips-instruction (name type))
252     (:print-function %print-mips-instruction))
253     (name "" :type simple-string)
254     type)
255    
256     (defun %print-mips-instruction (instr stream depth)
257     (declare (ignore depth))
258     (format stream "#<MIPS instruction ~A>" (mips-instruction-name instr)))
259    
260    
261     (defconstant mips-instruction-bits 6)
262    
263     (defvar *mips-instructions*
264     (make-array (ash 1 mips-instruction-bits)))
265     (proclaim '(type *mips-instructions* 'simple-vector))
266    
267     (defmacro def-mips-instr (name op-code type)
268     `(let ((name ,name)
269     (type ,type))
270     (unless (mips-instruction-type-p type)
271     (warn "~S is an unknown instruction type" type))
272     (setf (svref *mips-instructions* ,op-code)
273     (make-mips-instruction name ,type))
274     name))
275    
276    
277     (defconstant mips-special-instruction-bits 6)
278    
279     (defvar *mips-special-instructions*
280     (make-array (ash 1 mips-special-instruction-bits)))
281     (proclaim '(type *mips-special-instructions* 'simple-vector))
282    
283     (defmacro def-mips-special-instr (name op-code type)
284     `(let ((name ,name)
285     (type ,type))
286     (unless (mips-instruction-type-p type)
287     (warn "~S is an unknown instruction type" type))
288     (setf (svref *mips-special-instructions* ,op-code)
289     (make-mips-instruction name ,type))
290     name))
291    
292    
293     (defconstant mips-bcond-instruction-bits 6)
294    
295     (defvar *mips-bcond-instructions*
296     (make-array (ash 1 mips-bcond-instruction-bits)))
297     (proclaim '(type *mips-bcond-instructions* 'simple-vector))
298    
299     (defmacro def-mips-bcond-instr (name op-code type)
300     `(let ((name ,name)
301     (type ,type))
302     (unless (mips-instruction-type-p type)
303     (warn "~S is an unknown instruction type" type))
304     (setf (svref *mips-bcond-instructions* ,op-code)
305     (make-mips-instruction name ,type))
306     name))
307    
308    
309     ;;;; Normal Opcodes
310    
311     (def-mips-instr "J" #b000010 :j-type)
312     (def-mips-instr "JAL" #b000011 :j-type)
313     (def-mips-instr "BEQ" #b000100 :branch2-type)
314     (def-mips-instr "BNE" #b000101 :branch2-type)
315     (def-mips-instr "BLEZ" #b000110 :branch-type)
316     (def-mips-instr "BGTZ" #b000111 :branch-type)
317    
318     (def-mips-instr "ADDI" #b001000 :si-type)
319     (def-mips-instr "ADDIU" #b001001 :si-type)
320     (def-mips-instr "SLTI" #b001010 :si-type)
321     (def-mips-instr "SLTIU" #b001011 :si-type)
322     (def-mips-instr "ANDI" #b001100 :ui-type)
323     (def-mips-instr "ORI" #b001101 :ui-type)
324     (def-mips-instr "XORI" #b001110 :ui-type)
325     (def-mips-instr "LUI" #b001111 :lui-type)
326    
327     (def-mips-instr "COP0" #b010000 :cop0-type)
328     (def-mips-instr "COP1" #b010001 :cop1-type)
329     (def-mips-instr "COP2" #b010010 :cop2-type)
330     (def-mips-instr "COP3" #b010011 :cop3-type)
331    
332     (def-mips-instr "LB" #b100000 :ls-type)
333     (def-mips-instr "LH" #b100001 :ls-type)
334     (def-mips-instr "LWL" #b100010 :ls-type)
335     (def-mips-instr "LW" #b100011 :ls-type)
336     (def-mips-instr "LBU" #b100100 :ls-type)
337     (def-mips-instr "LHU" #b100101 :ls-type)
338     (def-mips-instr "LWR" #b100110 :ls-type)
339    
340     (def-mips-instr "SB" #b101000 :ls-type)
341     (def-mips-instr "SH" #b101001 :ls-type)
342     (def-mips-instr "SWL" #b101010 :ls-type)
343     (def-mips-instr "SW" #b101011 :ls-type)
344     (def-mips-instr "SWR" #b101110 :ls-type)
345    
346     (def-mips-instr "LWC0" #b110000 :cop0-type)
347     (def-mips-instr "LWC1" #b110001 :cop1-type)
348     (def-mips-instr "LWC2" #b110010 :cop2-type)
349     (def-mips-instr "LWC3" #b110011 :cop3-type)
350    
351     (def-mips-instr "SWC0" #b111000 :cop0-type)
352     (def-mips-instr "SWC1" #b111001 :cop1-type)
353     (def-mips-instr "SWC2" #b111010 :cop2-type)
354     (def-mips-instr "SWC3" #b111011 :cop3-type)
355    
356    
357     ;;;; SPECIAL Opcodes
358    
359     (defconstant special-op #b000000)
360    
361     (def-mips-special-instr "SLL" #b000000 :shift-type)
362     (def-mips-special-instr "SRL" #b000010 :shift-type)
363     (def-mips-special-instr "SRA" #b000011 :shift-type)
364     (def-mips-special-instr "SLLV" #b000100 :shiftv-type)
365     (def-mips-special-instr "SRLV" #b000110 :shiftv-type)
366     (def-mips-special-instr "SRAV" #b000111 :shiftv-type)
367    
368     (def-mips-special-instr "JR" #b001000 :jr-type)
369     (def-mips-special-instr "JALR" #b001001 :jalr-type)
370     (def-mips-special-instr "SYSCALL" #b001100 :syscall-type)
371     (def-mips-special-instr "BREAK" #b001101 :break-type)
372    
373     (def-mips-special-instr "MFHI" #b010000 :mf-type)
374     (def-mips-special-instr "MTHI" #b010001 :mt-type)
375     (def-mips-special-instr "MFLO" #b010010 :mf-type)
376     (def-mips-special-instr "MTLO" #b010011 :mt-type)
377    
378     (def-mips-special-instr "MULT" #b011000 :mult-type)
379     (def-mips-special-instr "MULTU" #b011001 :mult-type)
380     (def-mips-special-instr "DIV" #b011010 :mult-type)
381     (def-mips-special-instr "DIVU" #b011011 :mult-type)
382    
383     (def-mips-special-instr "ADD" #b100000 :r3-type)
384     (def-mips-special-instr "ADDU" #b100001 :r3-type)
385     (def-mips-special-instr "SUB" #b100010 :r3-type)
386     (def-mips-special-instr "SUBU" #b100011 :r3-type)
387     (def-mips-special-instr "AND" #b100100 :r3-type)
388     (def-mips-special-instr "OR" #b100101 :r3-type)
389     (def-mips-special-instr "XOR" #b100110 :r3-type)
390     (def-mips-special-instr "NOR" #b100111 :r3-type)
391    
392     (def-mips-special-instr "SLT" #b101010 :r3-type)
393     (def-mips-special-instr "SLTU" #b101011 :r3-type)
394    
395    
396     ;;;; BCOND Opcodes
397    
398     (defconstant bcond-op #b000001)
399    
400     (def-mips-bcond-instr "BLTZ" #b00000 :branch-type)
401     (def-mips-bcond-instr "BLTZAL" #b00001 :branch-type)
402    
403     (def-mips-bcond-instr "BLTZAL" #b10000 :branch-type)
404     (def-mips-bcond-instr "BGEZAL" #b10001 :branch-type)
405    
406    
407     ;;;; Signed-Ldb
408    
409     (defun signed-ldb (byte-spec integer)
410     (let ((unsigned (ldb byte-spec integer))
411     (length (byte-size byte-spec)))
412     (if (logbitp (1- length) unsigned)
413     (- unsigned (ash 1 length))
414     unsigned)))
415    
416    
417     ;;;; Instruction Decoding
418    
419     (defun mips-instruction (word)
420     (let* ((opcode (ldb (byte 6 26) word)))
421     (cond ((= opcode special-op)
422     (let ((function (ldb (byte 6 0) word)))
423     (svref *mips-special-instructions* function)))
424     ((= opcode bcond-op)
425     (let ((cond (ldb (byte 5 16) word)))
426     (svref *mips-bcond-instructions* cond)))
427     (t
428     (svref *mips-instructions* opcode)))))
429    
430    
431     ;;;; Disassemble-Instruction
432    
433     (defun disassemble-instruction (word &optional (stream t))
434 ch 1.5 (let* ((instr (mips-instruction word)))
435 ch 1.1 (unless instr
436     (format stream "UNKNOWN INSTR (#x~X)~%" word)
437 ch 1.4 (return-from disassemble-instruction (values nil nil)))
438 ch 1.1 (let* ((instr-name (mips-instruction-name instr))
439     (instr-type (mips-instruction-type instr))
440     (closure (gethash instr-type *mips-instruction-types*)))
441     (cond (closure
442     (funcall closure instr-name word stream))
443     (t
444     (format stream "UNKNOWN TYPE (~A/~S/#x~X)~%"
445 ch 1.4 instr-name instr-type word)))
446     (values instr-name instr-type))))
447 ch 1.1
448    
449     ;;; Dissassemble-Code-Vector
450    
451 ch 1.4 (defconstant delay-slot-instruction-types
452     '(:j-type :jr-type :jalr-type :branch-type :branch2-type))
453    
454 ch 1.1 (defun disassemble-code-vector (code-vector length &optional (stream t))
455 ch 1.4 (do ((i 0 (+ i 4))
456     (*current-instruction-number* 0 (1+ *current-instruction-number*))
457     (instruction-in-delay-slot-p nil))
458 ch 1.1 ((>= i length))
459 ch 1.4 (unless instruction-in-delay-slot-p
460     (format stream "~6D:" *current-instruction-number*))
461     (multiple-value-bind
462     (name type)
463 ch 1.5 (disassemble-instruction (logior (aref code-vector i)
464     (ash (aref code-vector (+ i 1)) 8)
465     (ash (aref code-vector (+ i 2)) 16)
466     (ash (aref code-vector (+ i 3)) 24))
467 ch 1.4 stream)
468     (declare (ignore name))
469     (cond ((member type delay-slot-instruction-types :test #'eq)
470     (setf instruction-in-delay-slot-p t))
471     (t
472     (setf instruction-in-delay-slot-p nil))))))

  ViewVC Help
Powered by ViewVC 1.1.5