1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:           PXU:disassemble.sl
4% Title:          Disassemble of instructions for IBM RS 6000 PSL
5% Author:         Winfried Neun
6% Created:        January 2, 1991
7% Status:         Experimental
8%
9% Copyright (c) 1990, Konrad-Zuse-Zentrum Berlin, All Rights Reserved
10%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
11%
12% The disassemble takes its information from the compiler patterns
13% ibmrs-instrs.sl and inverts them in order to disassemble
14%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
15
16(compiletime (flag '(dispatch-disassemble safe-cdr special-dispatch-disassemble
17        cop1-dispatch-disassemble bcond-dispatch-disassemble
18        normal-dispatch-disassemble print-instruction prinbl prinb prinbo
19        prinbn prindig) 'iinternalfunction))
20
21(fluid '(*instrsvect* *special19opcodevect* *regnames* *special31opcodevect*
22         *special63opcodevect* *floatopcodevect* klingelbeutel))
23
24(setq *regnames*
25   '((0 . "reg t") (1 . "reg st") (3 . "reg 1") (4 . "reg 2") (5 . "reg 3")
26     (6 . "reg 4") (7 . "reg 5") (8 . "reg t2") (9 . "reg t3") (10 . "reg t4")
27     (11 . "reg t5") (12 . "reg t6") (13 . "reg NIL") (14 . "reg bndstkptr")
28    (15 . "reg bndstklowerbound") (16 . "reg bndstkupperbound")
29    (17 . "reg symfncc") (18 . "reg symvalc") (19 . "reg t1")
30    (20 . "reg heaplast") (21 . "reg heaptrapbound")
31    (22 . "frame 9") (23 . "frame 8") (24 . "frame 7") (26 . "frame 6")
32    (27 . "frame 5") (28 . "frame 4") (29 . "frame 3")
33    (25 . "frame 2") (30 . "frame 1") (31 . "reg returnaddr")))
34
35(setq   *instrsvect* (mkvect 64)
36        *special19opcodevect* (mkvect 2048)
37        *special31opcodevect* (mkvect 4096)
38        *special63opcodevect* (mkvect 2048)
39        *floatopcodevect* (mkvect 1024))
40
41
42(compiletime
43 (progn
44  (de load-instruction-vectors (id)
45     (when (get id '*opcode*)  (read-normal-instruction id))
46     (when (get id '*special31*) (read-special-instruction id))
47     (when (get id '*special63*) (read-scaled-instruction id))
48     (when (get id '*special19*) (read-bitfield-instruction id))
49  )
50
51  (de read-special-instruction (id)
52     (prog (opcode format)
53       (setq opcode (get id '*special31*))
54       (setq format (lshift (car opcode) 1))
55       (when (memq 'oe opcode)  (setq format (plus2 (expt 2 11) format)))
56       (when (memq 'rc opcode)  (setq format (plus2 1 format)))
57       (setq opcode format)
58       (setq format (or (get id '*xo-format*)
59			(get id '*x-format*)))
60       (push `(putv *special31opcodevect* ,opcode ',(list id format))
61            klingelbeutel)))
62
63  (de read-float-instruction (id)
64     (prog (opcode format)
65       (setq opcode (get id '*float*))
66       (setq opcode (lor (lshift (car opcode) 5) (cadr opcode)))
67       (setq format (get id '*r-format*))
68       (push `(putv *floatopcodevect* ,opcode ',(list id format))
69            klingelbeutel)))
70
71  (de read-scaled-instruction (id)
72
73     (prog (opcode format)
74       (setq opcode (get id '*special63*))
75       (setq format (lshift (car opcode) 1))
76       (when (memq 'rc opcode)  (setq format (plus2 1 format)))
77       (setq opcode format)
78       (setq format (get id '*a-format*))
79       (push `(putv *special63opcodevect* ,opcode ',(list id format))
80                klingelbeutel)))
81
82  (de read-bitfield-instruction (id)
83     (prog (opcode format)
84       (setq opcode (lshift (car (get id '*special19*)) 1))
85       (if (memq 'lk (get id '*special19*)) (setq opcode (plus2 opcode 1)))
86       (setq format (get id '*xl-format*))
87       (push `(putv *special19opcodevect* ,opcode ',(list id format))
88                klingelbeutel)))
89
90  (de read-normal-instruction (id)
91     (prog (opcode format)
92       (setq opcode (car (get id '*opcode*)))
93       (setq format (or (get id '*i-format*)
94			(get id '*m-format*)
95			(get id '*b-format*)
96                        (get id '*d-format*)))
97       (push `(putv *instrsvect* ,opcode ',(list id format))
98                klingelbeutel)))
99))
100% installing the vectors now:
101
102(compiletime
103 (dm generate-it()
104 (setq klingelbeutel nil)
105 (mapobl (function load-instruction-vectors))
106 (cons 'progn klingelbeutel)))
107
108(generate-it)
109
110(de dispatch-disassemble (where word nextword)
111   (prog (op instr)
112     (prinbn where 8) (tab 15)
113     (prinbn word  8) (tab 30)
114     (setq op (wshift word -26))  % the opcode
115     (cond ((eq op 19) (special-dispatch-disassemble word ))
116           ((eq op 31) (special-31-dispatch-disassemble word ))
117           ((eq op 63) (bitfield-dispatch-disassemble word ))
118           (t (normal-dispatch-disassemble where word nextword)))
119)
120))
121
122% words will be split to sanitize the gc problem with unweaponed words
123(de safe-cdr (x) (cond ((null x) x) (t (cdr x))))
124
125(de special-dispatch-disassemble (word)
126  (prog (instr secondary tertiary rs ra rb rt bo bi)
127    (setq secondary (field word 21 10))  % the secondary opcode
128    (setq tertiary  (field word 31 1))  % the tertiary opcode
129    (setq instr (getv *special19opcodevect*
130                        (wor (wshift secondary 1) tertiary)))
131    (when (atom instr) (print  " ???? " ) (return nil))
132    (setq ra  (cdr (assoc (field word 11 5) *regnames*)))
133    (setq rb  (cdr (assoc (field word 16 5) *regnames*)))
134    (setq rs  (cdr (assoc (field word 6  5) *regnames*)))
135    (setq rt rs)
136    (setq bo (field word 6  5))
137    (cond ((wlessp bo 8) (setq bo "false"))
138          ((wlessp bo 15)(setq bo "true"))
139          ((eq bo 20)    (setq bo "always")))
140    (setq bi (field word 11 5))
141    (cond ((eq bi 0) (setq bi "lt"))
142         ((eq bi 1) (setq bi "gt"))
143         ((eq bi 2) (setq bi "eq"))
144         ((eq bi 3) (setq bi "so")))
145    (print-instruction
146      (pair '(instr rs ra rb rt bo bi bt ba bb)
147        (list instr rs ra rb rt bo bi rt ra rb))
148              (safe-cdr instr)) %the format
149))
150
151(de special-31-dispatch-disassemble (word)
152  (prog (instr secondary tertiary rs ra rb rt Oe spr bf)
153    (setq secondary (field word 21 10))  % the secondary opcode
154    (setq tertiary  (field word 31 1))  % the tertiary opcode
155    (setq instr (getv *special31opcodevect*
156		(wor (wshift secondary 1) tertiary )))
157    (when (atom instr) (print  " ???? " ) (return nil))
158    (setq bf (field word 6 3))
159    (setq ra  (cdr (assoc (setq spr (field word 11 5)) *regnames*)))
160    (setq rb  (cdr (assoc (field word 16 5) *regnames*)))
161    (setq rs  (cdr (assoc (field word 6  5) *regnames*)))
162    (setq rt rs)
163    (setq spr (atsoc spr '((0 . "mq") (1 . "xer") (4 . "rctu")
164		(5 . "rctl") (6 . "dec") (8 . "lr") (9 . "ctr"))))
165    (when spr (setq spr (cdr spr)))
166    (print-instruction
167              (pair '(instr rs ra rb rt spr sh bf)
168		 (list instr rs ra rb rt spr (field word 16 5) bf))
169              (safe-cdr instr)) %the format
170))
171
172(de bitfield-dispatch-disassemble (word nextword)
173  (prog (instr secondary tertiary rs ra rb rt bo bi)
174    (setq secondary (field word 21 10))  % the secondary opcode
175    (setq tertiary  (field word 31 1))  % the tertiary opcode
176    (setq instr (getv *special31opcodevect*
177                        (wor (wshift secondary 1) tertiary)))
178    (when (atom instr) (print  " ???? " ) (return nil))
179    (setq ra  (cdr (assoc (field word 11 5) *regnames*)))
180    (setq rb  (cdr (assoc (field word 16 5) *regnames*)))
181    (setq rs  (cdr (assoc (field word 6  5) *regnames*)))
182    (setq rt rs)
183    (print-instruction
184      (pair '(instr rs ra rb rt bo bi bt ba bb )
185         (list instr rs ra rb rt bo bi rt ra rb))
186              (safe-cdr instr)) %the format
187))
188
189(de normal-dispatch-disassemble (where word nextword)
190  (prog (op instr ra rb si d26 d16 rt based cc bf ui me mb bi bo)
191    (setq op (wshift word -26))
192    (setq instr (getv *instrsvect* op))
193    (when (atom instr) (print  " ???? " ) (return nil))
194    (setq ra (cdr (assoc (field word 11 5) *regnames*)))
195    (setq rt  (cdr (assoc (field word 6  5) *regnames*)))
196    (setq rb (field word 16 5))
197    (setq bf (field word 6 3))
198    (setq si (signedfield word 16 16))
199    (setq ui (field word 16 16))
200    (setq d26 (wplus2  where (wshift (signedfield word 6 24) 2)))
201    (setq d16 (wplus2  where (wshift (signedfield word 16 14) 2)))
202    (setq d26 (bldmsg "%x" d26))
203    (setq d16 (bldmsg "%x" d16))
204    (setq based (bldmsg "%w,%w" ra si))
205    (setq mb (field word 21 5))
206    (setq me (field word 26 5))
207    (setq bo (field word 6  5))
208    (cond ((wlessp bo 8) (setq bo "false"))
209          ((wlessp bo 15)(setq bo "true"))
210          ((eq bo 20)    (setq bo "always")))
211    (setq bi (field word 11 5))
212    (cond ((eq bi 0) (setq bi "lt"))
213         ((eq bi 1) (setq bi "gt"))
214         ((eq bi 2) (setq bi "eq"))
215         ((eq bi 3) (setq bi "so")))
216    (print-instruction
217      (pair '(instr ra si target target-14 rt based cc bf rs ui sh me mb bi bo)
218        (list instr ra si d26 d16 rt based cc bf rt ui rb me mb bi bo))
219              (safe-cdr instr)) %the format
220))
221
222(de print-instruction (alist format)
223   (prog (fmtitem institem comma comment)
224     (tab 30)
225     (prin2 (cadr (atsoc 'instr alist)))
226     (tab 40)
227     (setq format (car format))
228    loop
229     (when (null format) (when comment (tab 70) (prin2 comment))
230                         (return (terpri)))
231     (setq fmtitem (car format))
232     (when (idp fmtitem)
233         (when comma (prin2 ","))
234         (setq comma t)
235         (setq institem (atsoc fmtitem alist))
236         (when (and (not (eq fmtitem 'based)) (null institem))
237                 (print (list "komisch:" format)))
238         (if (eq fmtitem 'based)
239              (progn (prin2 (cdr institem))
240                     (when (equal (cdr (atsoc 'ra alist)) "reg st")
241                           (setq comment (cdr (atsoc 'si alist)))
242                           (setq comment (lshift comment -2))
243                           (setq comment (bldmsg "Frame (%w)" comment)))
244                     (when (equal (cdr (atsoc 'ra alist)) "reg symvalc")
245                           (setq comment (cdr (atsoc 'si alist)))
246                           (if (wgreaterp comment 28000)
247                              (setq comment (bldmsg "Extrareg%d"
248     					(lshift (wplus2 comment -28000) -2)))
249                             (setq comment (lshift (wplus2 comment 32000) -2)))
250                           (when (numberp comment)
251					(setq comment (symnam comment))))
252                     (when (equal (cdr (atsoc 'ra alist)) "reg symfncc")
253                           (setq comment (cdr (atsoc 'si alist)))
254                           (setq comment (wshift (wplus2 comment 32000) -2))
255                           (setq comment (symnam comment))))
256             (prin2 (if (pairp institem) (cdr institem)
257                                         institem))))
258     (setq format (cdr format))
259     (go loop)))
260
261(compiletime (put 'memo 'opencode '((lwz (reg 1) (displacement (reg 1) 0)))))
262
263(de disassemble (x)
264 (prog (stop i ll)
265  (setq ll (linelength 120))
266  (setq i x)
267  (when (idp x) (when (funboundp x) (error 0 (list x "not compiled")))
268                (setq i (wgetv symfnc (idinf x))))
269  (prin2l (list "**** Function :" x " at " (inf i))) (terpri) (terpri)
270  (while (wgreaterp (wshift (memo i) -1) 15)
271    (dispatch-disassemble i (memo i) (getmem (wplus2 i 4)))
272    (setq i (wplus2 i 4)))
273  (linelength ll)
274))
275
276(de prinbl (l)                  % binary (octal) printing of a list
277     (mapc l (function prinb)))
278
279(de prinb (it)                  % binary (octal) printing of an item
280     (cond ((numberp it)(prinbo it))
281           ((eq it 't1) (tab 35))
282           ((eq it 't2) (tab 60))
283           (t       (prin2 it))))
284
285(de prinbo (it)
286      (cond ((wlessp it 0) (prin2 "-") (prinbo (wminus it)))
287            ((wgeq it 10)  (prin2 "x'") (prinbn it 1))
288    (t            (prinbn it 1))))
289
290(de prinbn (it n)                % print an octal number
291     (cond ((and (weq it 0) (wleq n 0)) nil)
292            (t (progn
293                  (prinbn (wshift it -4) (wplus2 n -1))
294                  (prindig (wand it 15))
295)    )     )  )
296
297(de prindig (dig)        % print a numeric digit
298     (if (wlessp dig 10) (writeChar  (wplus2 dig 48))
299           (writechar (wplus2 65 (wdifference dig 10)))))
300