fix to Random>>next: 1.0 should not be included in return values
[k8lst.git] / modules / disasm.st
blob8604ed7bddfc58a34dfd24d785e4acd17db5c53c
2  coded by Ketmar // Vampire Avalon (psyc://ketmar.no-ip.org/~Ketmar)
3  Understanding is not required. Only obedience.
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.
11 Package [
12   Debug
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"
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   |
41   pc [
42     ^pc
43   ]
44   pc: aVal [
45     pc := aVal
46   ]
48   length [
49     ^length
50   ]
51   length: aVal [
52     length := aVal
53   ]
54   mnemonics [
55     ^mnemonics
56   ]
57   mnemonics: aVal [
58     mnemonics := aVal
59   ]
61   jmpDest [
62     ^jmpDest
63   ]
64   jmpDest: aVal [
65     jmpDest := aVal
66   ]
68   litNum [
69     ^litNum
70   ]
71   litNum: aVal [
72     litNum := aVal
73   ]
75   unNum [
76     ^unNum
77   ]
78   unNum: aVal [
79     unNum := aVal
80   ]
82   binNum [
83     ^binNum
84   ]
85   binNum: aVal [
86     binNum := aVal
87   ]
89   msgSym [
90     ^msgSym
91   ]
92   msgSym: aVal [
93     msgSym := aVal
94   ]
96   const [
97     ^const
98   ]
99   const: aVal [
100     const := aVal
101   ]
103   varNum [
104     ^varNum
105   ]
106   varNum: aVal [
107     varNum := aVal
108   ]
110   varSym [
111     ^varSym
112   ]
113   varSym: aVal [
114     varSym := aVal
115   ]
117   argCount [
118     ^argCount
119   ]
120   argCount: aVal [
121     argCount := aVal
122   ]
124   primNum [
125     ^primNum
126   ]
127   primNum: aVal [
128     primNum := aVal
129   ]
131   primName [
132     ^primName
133   ]
134   primName: aVal [
135     primName := aVal
136   ]
138   tempLoc [
139     ^tempLoc
140   ]
141   tempLoc: aVal [
142     tempLoc := aVal
143   ]
145   printString [
146     ^mnemonics
147   ]
151 DisasmedInstruction subclass: DisasmPushVar [
152   ^new: aMnemo varNum: aVarNum [
153     ^(self new);
154       mnemonics: aMnemo;
155       varNum: aVarNum.
156   ]
158   printString [
159     ^(mnemonics printWidth: 16) + '#' + varSym asString
160   ]
163 DisasmPushVar subclass: DisasmPushInstance [
164   ^new: aVarNum [
165     ^self new: 'PushInstance' varNum: aVarNum
166   ]
169 DisasmPushVar subclass: DisasmPushArgument [
170   ^new: aVarNum [
171     ^self new: 'PushArgument' varNum: aVarNum
172   ]
175 DisasmPushVar subclass: DisasmPushTemporary [
176   ^new: aVarNum [
177     ^self new: 'PushTemporary' varNum: aVarNum
178   ]
182 DisasmedInstruction subclass: DisasmAssignVar [
183   ^new: aMnemo varNum: aVarNum [
184     ^(self new);
185       mnemonics: aMnemo;
186       varNum: aVarNum.
187   ]
189   printString [
190     ^(mnemonics printWidth: 16) + '#' + varSym asString
191   ]
194 DisasmAssignVar subclass: DisasmAssignInstance [
195   ^new: aVarNum [
196     ^self new: 'AssignInstance' varNum: aVarNum
197   ]
200 DisasmAssignVar subclass: DisasmAssignArgument [
201   ^new: aVarNum [
202     ^self new: 'AssignArgument' varNum: aVarNum
203   ]
206 DisasmAssignVar subclass: DisasmAssignTemporary [
207   ^new: aVarNum [
208     ^self new: 'AssignTemporary' varNum: aVarNum
209   ]
213 DisasmedInstruction subclass: DisasmPushLiteral [
214   ^new: aLitNum [
215     ^(self new);
216       mnemonics: 'PushLiteral';
217       litNum: aLitNum.
218   ]
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   ]
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   ]
241   printString [
242     ^(mnemonics printWidth: 16) + const asString
243   ]
247 DisasmedInstruction subclass: DisasmMarkArguments [
248   ^new: aArgNo [
249     ^(self new);
250       mnemonics: 'MarkArguments';
251       argCount: aArgNo.
252   ]
254   printString [
255     ^(mnemonics printWidth: 16) + argCount asString
256   ]
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   ]
269   printString [
270     ^(mnemonics printWidth: 16) + 'argc: ' + argCount asString + ' jmpDest: ' + jmpDest asString + ' locStart: ' + tempLoc asString
271   ]
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   ]
283   printString [
284     ^(mnemonics printWidth: 16) + '#' + msgSym asString
285   ]
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   ]
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   ]
311 DisasmSendMsg subclass: DisasmSendMessage [
312   ^new: aLitNum name: aNameSym [
313     ^self new: 'Message' litNum: aLitNum name: aNameSym
314   ]
317 DisasmSendMsg subclass: DisasmSendToSuper [
318   ^new: aLitNum name: aNameSym [
319     ^self new: 'ToSuper' litNum: aLitNum name: aNameSym
320   ]
324 DisasmedInstruction subclass: DisasmDoPrimitive [
325   ^new: aPrimNum argCount: aArgNo name: aName [
326     ^(self new); mnemonics: 'DoPrimitive'; primNum: aPrimNum; argCount: aArgNo; primName: aName
327   ]
329   printString [
330     ^(mnemonics printWidth: 16) + '#' + primName asString + ' argc: ' + argCount asString
331   ]
335 DisasmedInstruction subclass: DisasmBranch [
336   ^new: aMnemo jmpDest: aJmpDest [
337     ^(self new); mnemonics: 'Branch' + aMnemo; jmpDest: aJmpDest
338   ]
340   printString [
341     ^(mnemonics printWidth: 16) + jmpDest asString
342   ]
346 DisasmedInstruction subclass: DisasmReturn [
347   ^new: aMnemo [
348     ^(self new); mnemonics: aMnemo + 'Return'
349   ]
353 DisasmedInstruction subclass: DisasmBreakpoint [
354   ^new [
355     ^(self basicNew); mnemonics: 'Breakpoint'
356   ]
360 DisasmedInstruction subclass: DisasmDuplicate [
361   ^new [
362     ^(self basicNew); mnemonics: 'Duplicate'
363   ]
367 DisasmedInstruction subclass: DisasmPopTop [
368   ^new [
369     ^(self basicNew); mnemonics: 'PopTop'
370   ]
374 DisasmedInstruction subclass: DisasmThisContext [
375   ^new [
376     ^(self basicNew); mnemonics: 'ThisContext'
377   ]
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   ]
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   ]
516   disassemble [
517     self disassemble: 1 at: 0 for: (byteCodes size)
518   ]
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   ]