modules/disasm.st

   1 "
   2  coded by Ketmar // Vampire Avalon (psyc://ketmar.no-ip.org/~Ketmar)
   3  Understanding is not required. Only obedience.
   4
   5  This program is free software. It comes without any warranty, to
   6  the extent permitted by applicable law. You can redistribute it
   7  and/or modify it under the terms of the Do What The Fuck You Want
   8  To Public License, Version 2, as published by Sam Hocevar. See
   9  http://sam.zoy.org/wtfpl/COPYING for more details.
  10 "
  11 Package [
  12   Debug
  13 ]
  14
  15
  16 "note that this disasm engine can be used to instrument bytecodes;
  17  if i'll add bytecode generator in each DisasmedInstruction, the
  18  engine can serve as a basis for writing peephole optimizers, for
  19  example, or inliners or such"
  20
  21
  22 class: DisasmedInstruction [
  23   | pc        "in the original bytecode"
  24     length    "of instruction bytecode"
  25     mnemonics "mnemonics, without operands"
  26     "operands area; unused vars are set to nil"
  27     jmpDest   "branch destination (for branches and block creation)"
  28     litNum    "literal number"
  29     unNum     "for SendUnary"
  30     binNum    "for SendBinary"
  31     msgSym    "for SendMessage"
  32     const     "for PushConstant"
  33     varNum    "for Push/Assign temps, args and insts"
  34     varSym    "temp, arg or inst varname; can be string for block vars"
  35     argCount  "for blocks, primitives and MarkArguments"
  36     primNum   "primitive number"
  37     primName  "string: primitive name"
  38     tempLoc   "for PushBlock"
  39   |
  40
  41   pc [
  42     ^pc
  43   ]
  44   pc: aVal [
  45     pc := aVal
  46   ]
  47
  48   length [
  49     ^length
  50   ]
  51   length: aVal [
  52     length := aVal
  53   ]
  54   mnemonics [
  55     ^mnemonics
  56   ]
  57   mnemonics: aVal [
  58     mnemonics := aVal
  59   ]
  60
  61   jmpDest [
  62     ^jmpDest
  63   ]
  64   jmpDest: aVal [
  65     jmpDest := aVal
  66   ]
  67
  68   litNum [
  69     ^litNum
  70   ]
  71   litNum: aVal [
  72     litNum := aVal
  73   ]
  74
  75   unNum [
  76     ^unNum
  77   ]
  78   unNum: aVal [
  79     unNum := aVal
  80   ]
  81
  82   binNum [
  83     ^binNum
  84   ]
  85   binNum: aVal [
  86     binNum := aVal
  87   ]
  88
  89   msgSym [
  90     ^msgSym
  91   ]
  92   msgSym: aVal [
  93     msgSym := aVal
  94   ]
  95
  96   const [
  97     ^const
  98   ]
  99   const: aVal [
 100     const := aVal
 101   ]
 102
 103   varNum [
 104     ^varNum
 105   ]
 106   varNum: aVal [
 107     varNum := aVal
 108   ]
 109
 110   varSym [
 111     ^varSym
 112   ]
 113   varSym: aVal [
 114     varSym := aVal
 115   ]
 116
 117   argCount [
 118     ^argCount
 119   ]
 120   argCount: aVal [
 121     argCount := aVal
 122   ]
 123
 124   primNum [
 125     ^primNum
 126   ]
 127   primNum: aVal [
 128     primNum := aVal
 129   ]
 130
 131   primName [
 132     ^primName
 133   ]
 134   primName: aVal [
 135     primName := aVal
 136   ]
 137
 138   tempLoc [
 139     ^tempLoc
 140   ]
 141   tempLoc: aVal [
 142     tempLoc := aVal
 143   ]
 144
 145   printString [
 146     ^mnemonics
 147   ]
 148 ]
 149
 150
 151 DisasmedInstruction subclass: DisasmPushVar [
 152   ^new: aMnemo varNum: aVarNum [
 153     ^(self new);
 154       mnemonics: aMnemo;
 155       varNum: aVarNum.
 156   ]
 157
 158   printString [
 159     ^(mnemonics printWidth: 16) + '#' + varSym asString
 160   ]
 161 ]
 162
 163 DisasmPushVar subclass: DisasmPushInstance [
 164   ^new: aVarNum [
 165     ^self new: 'PushInstance' varNum: aVarNum
 166   ]
 167 ]
 168
 169 DisasmPushVar subclass: DisasmPushArgument [
 170   ^new: aVarNum [
 171     ^self new: 'PushArgument' varNum: aVarNum
 172   ]
 173 ]
 174
 175 DisasmPushVar subclass: DisasmPushTemporary [
 176   ^new: aVarNum [
 177     ^self new: 'PushTemporary' varNum: aVarNum
 178   ]
 179 ]
 180
 181
 182 DisasmedInstruction subclass: DisasmAssignVar [
 183   ^new: aMnemo varNum: aVarNum [
 184     ^(self new);
 185       mnemonics: aMnemo;
 186       varNum: aVarNum.
 187   ]
 188
 189   printString [
 190     ^(mnemonics printWidth: 16) + '#' + varSym asString
 191   ]
 192 ]
 193
 194 DisasmAssignVar subclass: DisasmAssignInstance [
 195   ^new: aVarNum [
 196     ^self new: 'AssignInstance' varNum: aVarNum
 197   ]
 198 ]
 199
 200 DisasmAssignVar subclass: DisasmAssignArgument [
 201   ^new: aVarNum [
 202     ^self new: 'AssignArgument' varNum: aVarNum
 203   ]
 204 ]
 205
 206 DisasmAssignVar subclass: DisasmAssignTemporary [
 207   ^new: aVarNum [
 208     ^self new: 'AssignTemporary' varNum: aVarNum
 209   ]
 210 ]
 211
 212
 213 DisasmedInstruction subclass: DisasmPushLiteral [
 214   ^new: aLitNum [
 215     ^(self new);
 216       mnemonics: 'PushLiteral';
 217       litNum: aLitNum.
 218   ]
 219
 220   printString [
 221     const class == Symbol ifTrue: [ ^(mnemonics printWidth: 16) + '#' + const asString ].
 222     const class == String ifTrue: [ ^(mnemonics printWidth: 16) + '\'' + const toPrintable + '\'' ].
 223     (const isKindOf: Collection) ifTrue: [ ^(mnemonics printWidth: 16) + '<' + const class asString + '>' ].
 224     ^(mnemonics printWidth: 16) + const printString
 225   ]
 226 ]
 227
 228
 229 DisasmedInstruction subclass: DisasmPushConstant [
 230   ^new: aConstNum [
 231     | obj |
 232     (obj := self new) mnemonics: 'PushConstant'.
 233     Case test: aConstNum;
 234       case: 0 do: [ obj const: nil ];
 235       case: 1 do: [ obj const: true ];
 236       case: 2 do: [ obj const: false ];
 237       else: [:t | obj const: t - 3 ].
 238     ^obj
 239   ]
 240
 241   printString [
 242     ^(mnemonics printWidth: 16) + const asString
 243   ]
 244 ]
 245
 246
 247 DisasmedInstruction subclass: DisasmMarkArguments [
 248   ^new: aArgNo [
 249     ^(self new);
 250       mnemonics: 'MarkArguments';
 251       argCount: aArgNo.
 252   ]
 253
 254   printString [
 255     ^(mnemonics printWidth: 16) + argCount asString
 256   ]
 257 ]
 258
 259
 260 DisasmedInstruction subclass: DisasmPushBlock [
 261   ^new: aArgNo jmp: aJmpDest tempLoc: aTempLoc [
 262     ^(self new);
 263       mnemonics: 'PushBlock';
 264       argCount: aArgNo;
 265       jmpDest: aJmpDest;
 266       tempLoc: aTempLoc.
 267   ]
 268
 269   printString [
 270     ^(mnemonics printWidth: 16) + 'argc: ' + argCount asString + ' jmpDest: ' + jmpDest asString + ' locStart: ' + tempLoc asString
 271   ]
 272 ]
 273
 274
 275 DisasmedInstruction subclass: DisasmSendMsg [
 276   ^new: aMnemo litNum: aLitNum name: aNameSym [
 277     | obj |
 278     (obj := self new); mnemonics: 'Send'+aMnemo; litNum: aLitNum.
 279     aNameSym class == Symbol ifTrue: [ obj msgSym: aNameSym ].
 280     ^obj
 281   ]
 282
 283   printString [
 284     ^(mnemonics printWidth: 16) + '#' + msgSym asString
 285   ]
 286 ]
 287
 288
 289 DisasmSendMsg subclass: DisasmSendUnary [
 290   ^new: aUnNum [
 291     | obj |
 292     (obj := self new) mnemonics: 'SendUnary'.
 293     aUnNum = 0 ifTrue: [ obj msgSym: #isNil ].
 294     aUnNum = 1 ifTrue: [ obj msgSym: #notNil ].
 295     ^obj
 296   ]
 297 ]
 298
 299
 300 DisasmSendMsg subclass: DisasmSendBinary [
 301   ^new: aBinNum [
 302     | obj bins |
 303     (obj := self new); mnemonics: 'SendBinary'; binNum: aBinNum.
 304     bins := #{< <= + - * / % > >= ~= = & | ==}.
 305     ((aBinNum >= 0) and: [ aBinNum < bins size ]) ifTrue: [ obj msgSym: (bins at: aBinNum + 1) ].
 306     ^obj
 307   ]
 308 ]
 309
 310
 311 DisasmSendMsg subclass: DisasmSendMessage [
 312   ^new: aLitNum name: aNameSym [
 313     ^self new: 'Message' litNum: aLitNum name: aNameSym
 314   ]
 315 ]
 316
 317 DisasmSendMsg subclass: DisasmSendToSuper [
 318   ^new: aLitNum name: aNameSym [
 319     ^self new: 'ToSuper' litNum: aLitNum name: aNameSym
 320   ]
 321 ]
 322
 323
 324 DisasmedInstruction subclass: DisasmDoPrimitive [
 325   ^new: aPrimNum argCount: aArgNo name: aName [
 326     ^(self new); mnemonics: 'DoPrimitive'; primNum: aPrimNum; argCount: aArgNo; primName: aName
 327   ]
 328
 329   printString [
 330     ^(mnemonics printWidth: 16) + '#' + primName asString + ' argc: ' + argCount asString
 331   ]
 332 ]
 333
 334
 335 DisasmedInstruction subclass: DisasmBranch [
 336   ^new: aMnemo jmpDest: aJmpDest [
 337     ^(self new); mnemonics: 'Branch' + aMnemo; jmpDest: aJmpDest
 338   ]
 339
 340   printString [
 341     ^(mnemonics printWidth: 16) + jmpDest asString
 342   ]
 343 ]
 344
 345
 346 DisasmedInstruction subclass: DisasmReturn [
 347   ^new: aMnemo [
 348     ^(self new); mnemonics: aMnemo + 'Return'
 349   ]
 350 ]
 351
 352
 353 DisasmedInstruction subclass: DisasmBreakpoint [
 354   ^new [
 355     ^(self basicNew); mnemonics: 'Breakpoint'
 356   ]
 357 ]
 358
 359
 360 DisasmedInstruction subclass: DisasmDuplicate [
 361   ^new [
 362     ^(self basicNew); mnemonics: 'Duplicate'
 363   ]
 364 ]
 365
 366
 367 DisasmedInstruction subclass: DisasmPopTop [
 368   ^new [
 369     ^(self basicNew); mnemonics: 'PopTop'
 370   ]
 371 ]
 372
 373
 374 DisasmedInstruction subclass: DisasmThisContext [
 375   ^new [
 376     ^(self basicNew); mnemonics: 'ThisContext'
 377   ]
 378 ]
 379
 380
 381 Method extend [
 382   disasmParseInstr: pc [
 383     "returns DisasmedInstruction or nil; pc is 0-based"
 384     | opcode oparg oplen res ac jmpd pname |
 385     "fetch opcode"
 386     oparg := (opcode := byteCodes at: pc + 1 ifAbsent: [ ^nil ]) bitAnd: 15.
 387     (opcode := opcode bitShift: -4) = 0 ifTrue: [
 388       "special opcode form"
 389       opcode := oparg.
 390       oparg := byteCodes at: pc + 2 ifAbsent: [ ^nil ].
 391       oplen := 2.
 392     ] ifFalse: [ oplen := 1 ].
 393     Case test: opcode;
 394       case: 1 do: [
 395         pname := self forClass instanceVariables.
 396         oparg >= pname size ifTrue: [ ^nil ].
 397         (res := DisasmPushInstance new: oparg); varSym: (pname at: oparg + 1)
 398       ];
 399       case: 2 do: [
 400         "FIXME: argNames can be nil"
 401         oparg = 0
 402           ifTrue: [ pname := #self ]
 403           ifFalse: [
 404             oparg > argNames size ifTrue: [ ^nil ].
 405             pname := argNames at: oparg ].
 406         (res := DisasmPushArgument new: oparg); varSym: pname
 407       ];
 408       case: 3 do: [
 409         tempNames ifNotNil: [
 410           oparg < tempNames size ifTrue: [ oparg := tempNames at: oparg + 1] ifFalse: [ oparg := '#' + oparg asString ].
 411         ] ifNil: [ oparg := '#' + oparg asString ].
 412         (res := DisasmPushTemporary new: oparg); varSym: oparg
 413       ];
 414       case: 4 do: [
 415         "FIXME: check oparg bounds"
 416         (res := DisasmPushLiteral new: oparg) const: (literals at: oparg + 1)
 417       ];
 418       case: 5 do: [ res := DisasmPushConstant new: oparg ];
 419       case: 6 do: [
 420         pname := self forClass instanceVariables.
 421         oparg >= pname size ifTrue: [ ^nil ].
 422         (res := DisasmAssignInstance new: oparg); varSym: (pname at: oparg + 1)
 423       ];
 424       case: 7 do: [
 425         "FIXME: argNames can be nil"
 426         oparg = 0
 427           ifTrue: [ pname := #self ]
 428           ifFalse: [
 429             oparg > argNames size ifTrue: [ ^nil ].
 430             pname := argNames at: oparg ].
 431         (res := DisasmAssignArgument new: oparg); varSym: (argNames at: oparg + 1)
 432       ];
 433       case: 8 do: [
 434         tempNames ifNotNil: [
 435           oparg < tempNames size ifTrue: [ oparg := tempNames at: oparg + 1] ifFalse: [ oparg := '#' + oparg asString ].
 436         ] ifNil: [ oparg := '#' + oparg asString ].
 437         (res := DisasmAssignTemporary new: oparg); varSym: oparg
 438       ];
 439       case: 9 do: [ res := DisasmMarkArguments new: oparg ];
 440       case: 10 do: [  "PushBlock"
 441         byteCodes size < (pc + oplen + 3) ifTrue: [ ^nil ].
 442         jmpd := byteCodes wordAt: pc + oplen + 1.
 443         ac := byteCodes at: pc + oplen + 3.
 444         oplen := oplen + 3.
 445         res := DisasmPushBlock new: ac jmp: jmpd tempLoc: oparg.
 446       ];
 447       case: 11 do: [ (res := DisasmSendUnary new: oparg) msgSym ifNil: [ ^nil ]];
 448       case: 12 do: [ (res := DisasmSendBinary new: oparg) msgSym ifNil: [ ^nil ]];
 449       case: 13 do: [  "SendMessage"
 450         "FIXME: check oparg bounds"
 451         (res := DisasmSendMessage new: oparg name: (literals at: oparg + 1)) msgSym ifNil: [ ^nil ]
 452       ];
 453       case: 14 do: [  "DoPrimitive"
 454         opcode := byteCodes at: pc + oplen + 1 ifAbsent: [ ^nil ].
 455         oplen := oplen + 1.
 456         (pname := System nameOfPrimitive: opcode) ifNil: [ pname := '#' + opcode asString ].
 457         res := DisasmDoPrimitive new: opcode argCount: oparg name: pname.
 458       ];
 459       case: 15 do: [  "DoSpecial"
 460         Case test: oparg;
 461           case: 0 do: [ res := DisasmBreakpoint new ];
 462           case: 1 do: [ res := DisasmReturn new: 'Self' ];
 463           case: 2 do: [ res := DisasmReturn new: 'Stack' ];
 464           case: 3 do: [ res := DisasmReturn new: 'Block' ];
 465           case: 4 do: [ res := DisasmDuplicate new ];
 466           case: 5 do: [ res := DisasmPopTop new ];
 467           when: [ :v | (v > 5) & (v < 11) ] do: [:bc |
 468             byteCodes size < (pc + oplen + 2) ifTrue: [ ^nil ].
 469             jmpd := byteCodes wordAt: pc + oplen + 1.
 470             oplen := oplen + 2.
 471             Case test: bc;
 472               case: 6 do: [ res := DisasmBranch new: '' jmpDest: jmpd ];
 473               case: 7 do: [ res := DisasmBranch new: 'IfTrue' jmpDest: jmpd ];
 474               case: 8 do: [ res := DisasmBranch new: 'IfFalse' jmpDest: jmpd ];
 475               case: 9 do: [ res := DisasmBranch new: 'IfNil' jmpDest: jmpd ];
 476               case: 10 do: [ res := DisasmBranch new: 'IfNotNil' jmpDest: jmpd ].
 477           ];
 478           case: 11 do: [  "SendToSuper"
 479             oparg := byteCodes at: pc + oplen + 1 ifAbsent: [ ^nil ].
 480             oplen := oplen + 1.
 481             "FIXME: check oparg bounds"
 482             (res := DisasmSendToSuper new: oparg name: (literals at: oparg + 1)) msgSym ifNil: [ ^nil ]
 483           ];
 484           case: 12 do: [ res := DisasmThisContext new ];
 485           else: [ ^nil ].
 486       ];
 487       else: [ ^nil ].
 488     res; pc: pc; length: oplen.
 489     ^res
 490   ]
 491
 492   disassemble: indent at: pc for: initCount [
 493     | pcend instr blockEnds |
 494     blockEnds := nil.
 495     pcend := pc + initCount.
 496     [ pc < pcend ] whileTrue: [
 497       (instr := self disasmParseInstr: pc) ifNil: [ ^self ].
 498       "show PC and indent listing of line"
 499       (pc printWidth: 4) print. ':' print. 1 to: indent do: [:x | ' ' print].
 500       instr printString printNl.
 501       pc := pc + instr length.
 502       instr class == DisasmPushBlock ifTrue: [
 503         indent := indent + 1.
 504         blockEnds ifNil: [ blockEnds := List new ].
 505         blockEnds add: instr jmpDest.
 506       ].
 507       blockEnds ifNotNil: [
 508         pc = blockEnds first ifTrue: [
 509           (blockEnds removeFirst) isEmpty ifTrue: [ blockEnds := nil ].
 510           indent := indent - 1.
 511         ].
 512       ].
 513     ]
 514   ]
 515
 516   disassemble [
 517     self disassemble: 1 at: 0 for: (byteCodes size)
 518   ]
 519 ]
 520
 521
 522 Class extend [
 523   disasmMethod: nm [
 524     | meth |
 525     meth := self allMethods at: nm ifAbsent: [ ^self error: 'no such method' ].
 526     'max stack size: ' print. meth stackSize printNl.
 527     meth disassemble.
 528   ]
 529 ]