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