Initial revision. All tests pass.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRAccess.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,33 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstruction subclass:#IRAccess
+ instanceVariableNames:'number name'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRAccess methodsFor:'accessing'!
+
+number
+
+ ^ number
+!
+
+number: num
+
+ number _ num
+! !
+
+!IRAccess methodsFor:'testing'!
+
+isRead
+ ^self isStore not
+! !
+
+!IRAccess class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRBlockReturnTop.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,45 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRReturn subclass:#IRBlockReturnTop
+ instanceVariableNames:'successor'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRBlockReturnTop methodsFor:'accessing'!
+
+successor: anObject
+
+ successor := anObject.
+!
+
+successorSequences
+ "sent to last instruction in sequence which is expected to be a jump and return instruction"
+
+ ^ { successor }
+! !
+
+!IRBlockReturnTop methodsFor:'interpret'!
+
+executeOn: interpreter
+ interpreter blockReturnTop.
+! !
+
+!IRBlockReturnTop methodsFor:'testing'!
+
+isBlockReturnTop
+
+ ^true.
+!
+
+isRemote
+ ^false.
+! !
+
+!IRBlockReturnTop class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRBuilder.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,361 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+Object subclass:#IRBuilder
+ instanceVariableNames:'ir tempMap jumpBackTargetStacks jumpAheadStacks currentSequence
+ sourceMapNodes sourceMapByteIndex'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRBuilder comment:'I provide a simple interface for constructing an IRMethod. For example, to create an ir method that compares first instVar to first arg and returns ''yes'' or ''no'' (same example as in BytecodeGenerator), do:
IRBuilder new
numRargs: 2;
addTemps: #(self a z); "rcvr, arg, & extra temp (not used here)"
pushTemp: #self;
pushInstVar: 1;
pushTemp: #a;
send: #>;
jumpAheadTo: #else if: false;
pushLiteral: ''yes'';
returnTop;
jumpAheadTarget: #else;
pushLiteral: ''no'';
returnTop;
ir
Sending #compiledMethod to an ir method will generate its compiledMethod. Sending #methodNode to it will decompile to its parse tree.
'
+!
+
+
+!IRBuilder class methodsFor:'instance creation'!
+
+new
+ ^ self basicNew initialize.
+
+ "Created: / 11-06-2008 / 00:51:36 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRBuilder methodsFor:'accessing'!
+
+currentSequence
+ ^currentSequence
+!
+
+properties: aDict
+ ir properties: aDict
+! !
+
+!IRBuilder methodsFor:'decompiling'!
+
+addJumpBackTarget: label to: sequence
+
+ (jumpBackTargetStacks at: label ifAbsentPut: [OrderedCollection new])
+ addLast: sequence
+!
+
+addTemps: newKeys
+
+ | keys i new |
+ keys := ir tempKeys.
+ i := keys size - 1. "zero-based (index 0 equals receiver)"
+ new := OrderedCollection new.
+ newKeys do: [:key |
+ tempMap at: key ifAbsentPut: [
+ new add: key.
+ i := i + 1]
+ ].
+ ir tempKeys: keys, new.
+!
+
+testJumpAheadTarget: label
+
+ jumpAheadStacks at: label ifPresent: [:stack |
+ [stack isEmpty] whileFalse: [self jumpAheadTarget: label]
+ ]
+! !
+
+!IRBuilder methodsFor:'initialize'!
+
+addTemp: tempKey
+
+ self addTemps: {tempKey}
+!
+
+initialize
+ ir := IRMethod new.
+ tempMap := Dictionary new.
+ jumpAheadStacks := IdentityDictionary new.
+ jumpBackTargetStacks := IdentityDictionary new.
+ sourceMapNodes := OrderedCollection new. "stack"
+
+ "Leave an empty sequence up front (guaranteed not to be in loop)"
+ ir startSequence:((IRSequence new orderNumber:0) method:ir).
+ currentSequence := (IRSequence new orderNumber:1) method:ir.
+ ir startSequence add:(IRJump new destination: currentSequence)
+!
+
+numRargs: n
+
+ ir numRargs: n.
+!
+
+primitiveNode: primNode
+
+ ir primitiveNode: primNode
+! !
+
+!IRBuilder methodsFor:'instr - old blocks'!
+
+blockReturnTop
+ | retInst newSequence |
+ retInst _ IRInstruction blockReturnTop.
+ self add:retInst.
+ newSequence _ IRSequence new orderNumber:currentSequence orderNumber +1.
+ newSequence method:ir.
+ currentSequence last isJumpOrReturn
+ ifFalse:[self add:(IRJump new destination:newSequence)].
+ currentSequence _ newSequence.
+ retInst successor:currentSequence
+!
+
+jumpOverBlockTo: labelSymbol
+ "Conditional jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self. This and its corresponding target is only good for one use. Other jumpAheadTo:... with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."
+
+ | instr |
+ "jumpAheadTarget: label will pop this and replace destination with its basic block"
+ (jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
+ addLast: (instr _ self add: (IRJumpOverBlock new)).
+ self startNewSequence.
+ instr blockSequence: currentSequence.
+! !
+
+!IRBuilder methodsFor:'instructions'!
+
+jumpAheadTarget: labelSymbol
+ "Pop latest jumpAheadTo: with this labelSymbol and have it point to this new instruction sequence"
+
+ | jumpInstr |
+ self startNewSequence.
+ jumpInstr := (jumpAheadStacks at: labelSymbol ifAbsent: [
+ self error: 'Missing jumpAheadTo: ', labelSymbol printString]) removeLast.
+ jumpInstr destination: currentSequence.
+!
+
+jumpAheadTo: labelSymbol
+ "Jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self. This is and its corresponding target is only good for one use. Other jumpAheadTo: with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."
+
+ "jumpAheadTarget: label will pop this and replace destination with its basic block"
+ (jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
+ addLast: (self add: IRJump new).
+ self startNewSequence.
+!
+
+jumpAheadTo: labelSymbol if: boolean
+ "Conditional jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self. This and its corresponding target is only good for one use. Other jumpAheadTo:... with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called."
+
+ | instr |
+ "jumpAheadTarget: label will pop this and replace destination with its basic block"
+ (jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
+ addLast: (instr _ self add: (IRJumpIf new boolean: boolean)).
+ self startNewSequence.
+ instr otherwise: currentSequence.
+!
+
+jumpBackTarget: labelSymbol
+ "Remember this basic block for a future jumpBackTo: labelSymbol. Stack up remembered targets with same name and remove them from stack for each jumpBackTo: called with same name."
+
+ self startNewSequence.
+ (jumpBackTargetStacks at: labelSymbol ifAbsentPut: [OrderedCollection new])
+ addLast: currentSequence.
+!
+
+jumpBackTo: labelSymbol
+ "Pop last remembered position with this label and write an unconditional jump to it"
+
+ | sequence |
+ sequence _ (jumpBackTargetStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpBackTarget: ', labelSymbol printString]) removeLast.
+ self add: (IRJump new destination: sequence).
+ self startNewSequence.
+!
+
+popTop
+
+ self add: IRInstruction popTop
+!
+
+pushBlock: irMethod
+
+ self add: (IRInstruction pushBlock: irMethod)
+!
+
+pushBlockMethod: irMethod
+
+ self add: (IRInstruction pushBlockMethod: irMethod)
+!
+
+pushDup
+
+ self add: IRInstruction pushDup
+!
+
+pushGlobal: object
+
+ self pushLiteralVariable: object
+
+ "Created: / 11-06-2008 / 11:21:23 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+pushInstVar: instVarIndex
+ "Receiver must be on top"
+
+
+ self add: (IRInstruction pushInstVar: instVarIndex).
+
+"
+ self pushLiteral: instVarIndex.
+ self send: #privGetField:.
+"
+!
+
+pushLiteral: object
+
+ self add: (IRInstruction pushLiteral: object)
+!
+
+pushLiteralVariable: object
+
+ self add: (IRInstruction pushLiteralVariable: object)
+!
+
+pushReceiver
+
+ self add: (IRInstruction pushReceiver)
+!
+
+pushTemp: key
+
+ | index |
+ index := tempMap at: key.
+ self add: (IRInstruction pushTemp: index)
+!
+
+pushThisContext
+
+ self add: (IRInstruction pushThisContext)
+!
+
+pushThisEnv
+
+ self add: (IRInstruction pushTemp: -1)
+!
+
+remoteReturn
+
+ self add: IRInstruction remoteReturn.
+ self startNewSequence.
+!
+
+returnTop
+
+ self add: IRInstruction returnTop.
+ self startNewSequence.
+!
+
+send: selector
+
+ self add: (IRInstruction send: selector)
+!
+
+send: selector toSuperOf: behavior
+
+ self add: (IRInstruction send: selector toSuperOf: behavior)
+!
+
+storeInstVar: instVarIndex
+ "receiver must be on top with new field value underneath"
+
+
+ self add: (IRInstruction storeInstVar: instVarIndex).
+
+ "self pushLiteral: instVarIndex.
+ self send: #privStoreIn:field:."
+!
+
+storeIntoLiteralVariable: object
+
+ self add: (IRInstruction storeIntoLiteralVariable: object)
+!
+
+storeTemp: key
+
+ | index |
+ index := tempMap at: key.
+ self add: (IRInstruction storeTemp: index)
+!
+
+storeThisEnv
+
+ self add: (IRInstruction storeTemp: -1)
+! !
+
+!IRBuilder methodsFor:'mapping'!
+
+mapToByteIndex: index
+ "decompiling"
+
+ sourceMapByteIndex _ index
+!
+
+mapToNode: object
+ "new instructions will be associated with object"
+
+ sourceMapNodes addLast: object
+!
+
+popMap
+
+ sourceMapNodes removeLast
+!
+
+sourceByteIndex
+ "decompiling"
+
+ ^ sourceMapByteIndex
+!
+
+sourceNode
+
+ ^ sourceMapNodes isEmpty
+ ifTrue: [nil]
+ ifFalse: [sourceMapNodes last]
+! !
+
+!IRBuilder methodsFor:'private'!
+
+add: instr
+
+ "Associate instr with current parse node or byte range"
+ instr sourceNode: self sourceNode.
+ instr bytecodeIndex: self sourceByteIndex.
+ ^ currentSequence add: instr
+!
+
+addLiteral: aSymbol
+
+ ir addLiteral: aSymbol
+!
+
+addLiterals: aSymbol
+
+ ir addLiterals: aSymbol
+!
+
+startNewSequence
+ "End current instruction sequence and start a new sequence to add instructions to. If ending block just falls through to new block then add an explicit jump to it so they stay linked"
+
+ | newSequence |
+ currentSequence isEmpty ifTrue:[^ self]. "block is still empty, continue using it"
+ newSequence _ IRSequence new orderNumber:currentSequence orderNumber +1.
+ newSequence method:ir.
+ currentSequence last isJumpOrReturn
+ ifFalse:[self add:(IRJump new destination:newSequence)].
+ currentSequence _ newSequence
+! !
+
+!IRBuilder methodsFor:'results'!
+
+ir
+
+ ^ ir
+! !
+
+!IRBuilder class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRBuilderTest.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,608 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+TestCase subclass:#IRBuilderTest
+ instanceVariableNames:''
+ classVariableNames:'TestToPush'
+ poolDictionaries:''
+ category:'NewCompiler-IR-Tests'
+!
+
+
+!IRBuilderTest class methodsFor:'as yet unclassified'!
+
+testToPush
+ ^TestToPush
+!
+
+testToPush: anObject
+
+ TestToPush := anObject
+! !
+
+!IRBuilderTest methodsFor:'testing'!
+
+halt
+ "Redefinition for testing the #send:toSuperOf:"
+
+ "Created: / 11-06-2008 / 16:08:52 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+isThisEverCalled
+ "Redefinition for testing the #send:toSuperOf:"
+!
+
+testDup
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: 3;
+ pushDup;
+
+ send: #=;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = true).
+
+!
+
+testInstVar
+
+ | aCompiledMethod irBuilder |
+ irBuilder := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushInstVar: 1;
+ pushInstVar: 2;
+ send: #+;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := irBuilder compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: (3@4) arguments: #() ) = 7).
+
+ "Modified: / 11-06-2008 / 13:16:41 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+testJumpAheadTo
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushTemp: #self ;
+
+ jumpAheadTo: #end;
+ pushLiteral: 3;
+ jumpAheadTarget: #end;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = nil).
+
+!
+
+testJumpAheadToIf
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushTemp: #self ;
+ pushLiteral: true;
+
+ "jumpAhaedTo pop the first element of thz stack"
+ jumpAheadTo: #end if: true;
+ pushLiteral: 3;
+ jumpAheadTarget: #end;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = nil).
+
+!
+
+testJumpBackTo
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushTemp: #self ;
+ pushLiteral: false;
+ jumpBackTarget: #begin;
+
+ "jumpAhaedTo pop the first element of the stack"
+ jumpAheadTo: #end if: true;
+ pushLiteral: true;
+ jumpBackTo: #begin;
+ jumpAheadTarget: #end;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = nil).
+
+!
+
+testLiteralArray
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: #(test 4 you);
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = #(test 4 you)).
+
+
+!
+
+testLiteralBoolean
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: true;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = true).
+
+
+!
+
+testLiteralCharacter
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: $e;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = $e).
+
+
+!
+
+testLiteralFloat
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: 2.0;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2.0).
+
+
+!
+
+testLiteralInteger
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: 2;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2).
+
+
+!
+
+testLiteralNil
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: nil;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: 4 arguments: #() ) = nil).
+
+
+!
+
+testLiteralString
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: 'hello';
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 'hello').
+
+
+!
+
+testLiteralSymbole
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: #you;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = #you).
+
+
+!
+
+testLiteralVariableClass
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteralVariable: Object binding;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = Object).
+
+
+!
+
+testLiteralVariableClassVariable
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteralVariable: (ArithmeticValue bindingOf: #ArithmeticSignal);
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = ArithmeticValue arithmeticSignal).
+
+ "Modified: / 11-06-2008 / 11:31:32 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+testLiteralVariableGlobale
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteralVariable: Smalltalk binding;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = Smalltalk).
+
+ "Modified: / 11-06-2008 / 11:32:07 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+testPopTop
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: true ;
+
+ pushLiteral: false;
+ popTop;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = true).
+
+ "Modified: / 11-06-2008 / 13:22:11 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+testPushReceiver
+
+ | iRMethod aCompiledMethod receiver |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushReceiver;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ receiver := (5@8).
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: receiver arguments: #() ) == receiver).
+!
+
+testPushTempArgument
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 3;
+ addTemps: #(self a b); "receiver and args declarations"
+ pushTemp: #a;
+ pushTemp: #b;
+ send: #+;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #(2 8) ) = 10).
+
+!
+
+testPushTempSelf
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushTemp: #self;
+ send: #class;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) == UndefinedObject).
+
+!
+
+testPushTempTemp
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self a); "receiver and args declarations"
+
+ pushTemp: #a;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: 5 arguments: #() ) = nil).
+
+!
+
+testPushThisContext
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self a); "receiver and args declarations"
+
+ pushThisContext;
+ send: #receiver;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: 5 arguments: #() ) = 5).
+
+!
+
+testPushThisEnv
+
+ | iRMethod aCompiledMethod receiver |
+
+ ^self.
+
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushThisContext;
+ pushLiteral: 5;
+ pushLiteral: ClosureEnvironment;
+ pushLiteral: 1;
+ send: #new:;
+ send: #privSetInstVar:put:;
+ pushThisEnv;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ receiver := Object new.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: receiver arguments: #()) isKindOf: ClosureEnvironment)
+
+ "Modified: / 11-06-2008 / 14:47:36 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+testSendSuper
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushReceiver;
+ send: #halt toSuperOf: IRBuilderTest;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self should: [(aCompiledMethod valueWithReceiver: (IRBuilderTest new) arguments: #())] raise: Error.
+
+ "Modified: / 11-06-2008 / 16:09:12 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+testStorIntoVariable
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+
+ pushLiteral: 4;
+ storeIntoLiteralVariable: (IRBuilderTest bindingOf: #TestToPush);
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ aCompiledMethod valueWithReceiver: nil arguments: #().
+ self assert: (IRBuilderTest testToPush = 4).
+ IRBuilderTest testToPush: nil.
+
+
+!
+
+testStoreTemp
+
+ | iRMethod aCompiledMethod |
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self a); "receiver and args declarations"
+
+ pushLiteral: 34;
+ storeTemp: #a;
+ pushTemp: #a;
+
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 34).
+
+ "Modified: / 11-06-2008 / 16:24:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+testStoreThisEnv
+
+ | iRMethod aCompiledMethod |
+
+ ^self.
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self a); "receiver and args declarations"
+ pushLiteral: ClosureEnvironment;
+ pushLiteral: 1;
+ send: #new:;
+ storeThisEnv;
+ pushThisContext;
+ pushLiteral: 5;
+ send: #privGetInstVar:;
+ returnTop;
+ ir.
+
+ aCompiledMethod := iRMethod compiledMethod.
+
+ self assert: (aCompiledMethod isKindOf: CompiledMethod).
+ self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) isKindOf: ClosureEnvironment).
+
+ "Modified: / 11-06-2008 / 14:47:51 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRBuilderTest class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRBytecodeGenerator.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,610 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+Object subclass:#IRBytecodeGenerator
+ instanceVariableNames:'seqOrder orderSeq jumps literals lastLiteral currentSeqId
+ currentSeqNum lastSpecialReturn instrMaps instrMap maxTemp stacks
+ stack primNum numArgs properties code seqCode'
+ classVariableNames:'BytecodeTable Bytecodes SpecialConstants SpecialSelectors'
+ poolDictionaries:''
+ category:'NewCompiler-Bytecode'
+!
+
+IRBytecodeGenerator comment:'I generate bytecodes in response to ''instructions'' messages being sent to me. I rewrite jumps at the end so their jump offsets are correct (see #bytecodes). For example, to create a compiled method that compares first instVar to first arg and returns ''yes'' or ''no'' (same example as in IRBuilder), do:
BytecodeGenerator new
numArgs: 1;
pushInstVar: 1;
pushTemp: 1;
send: #>;
if: false goto: #else;
pushLiteral: ''yes'';
returnTop;
label: #else;
pushLiteral: ''no'';
returnTop;
compiledMethod
You can send #ir to the compiledMethod to decompile to its IRMethod, and you can send #methodNode to either to decompile to its parse tree.
'
+!
+
+
+!IRBytecodeGenerator class methodsFor:'instance creation'!
+
+new
+ ^ self basicNew initialize.
+
+ "Created: / 11-06-2008 / 13:53:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRBytecodeGenerator methodsFor:'accessing default'!
+
+defaultStackCounter
+
+ ^IRStackCount
+
+ "Modified: / 11-06-2008 / 13:51:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRBytecodeGenerator methodsFor:'initialize'!
+
+initialize
+
+ literals := OrderedCollection new.
+ "The following dicts are keyed by sequence id given by client in label: (and gotos)."
+ seqOrder := IdentityDictionary new. "seqId -> seq order num"
+ seqCode := IdentityDictionary new. "seqId -> seq bytecodes"
+ jumps := IdentityDictionary new. "seqId -> last jump instr"
+ instrMaps := IdentityDictionary new. "seqId -> (clientInstr -> bytecode pos)"
+ stacks := IdentityDictionary new. "seqId -> stackCount"
+ maxTemp := 0.
+ primNum := 0.
+ numArgs := 0.
+ currentSeqNum := 0.
+ orderSeq := Dictionary new. "reverse map of seqOrder"
+
+ "starting label in case one is not provided by client"
+ self label: self newDummySeqId.
+
+ "Modified: / 11-06-2008 / 14:43:48 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+numArgs: n
+
+ numArgs := n
+
+ "Modified: / 11-06-2008 / 14:39:46 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+primitiveNode: aPrimitiveNode
+
+ literals isEmpty ifFalse: [self error: 'init prim before adding instructions'].
+ aPrimitiveNode spec ifNotNil: [literals add: aPrimitiveNode spec].
+ primNum _ aPrimitiveNode num.
+! !
+
+!IRBytecodeGenerator methodsFor:'instructions'!
+
+goto: seqId
+
+ stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])).
+
+ self saveLastJump: (Message
+ selector: #from:goto:
+ arguments: {currentSeqId. seqId}).
+ self from: currentSeqId goto: seqId.
+!
+
+if: bool goto: seqId
+
+ | otherwiseSeqId |
+ otherwiseSeqId _ self newDummySeqId.
+ self if: bool goto: seqId otherwise: otherwiseSeqId.
+ self label: otherwiseSeqId.
+!
+
+if: bool goto: seqId1 otherwise: seqId2
+
+ stack pop.
+ stacks at: seqId1 put: (stack linkTo: (stacks at: seqId1 ifAbsentPut: [nil])).
+ stacks at: seqId2 put: (stack linkTo: (stacks at: seqId2 ifAbsentPut: [nil])).
+
+ self saveLastJump: (Message
+ selector: #from:if:goto:otherwise:
+ arguments: {currentSeqId. bool. seqId1. seqId2}).
+ self from: currentSeqId if: bool goto: seqId1 otherwise: seqId2.
+!
+
+initializeStackCounter
+ ^ self defaultStackCounter new
+!
+
+label: seqId
+ (currentSeqId notNil and: [(jumps at: currentSeqId) isNil])
+ ifTrue:
+ ["make previous implicit goto explicit"
+
+ self goto: seqId].
+ lastSpecialReturn := nil.
+ currentSeqId := seqId.
+ currentSeqNum := currentSeqNum + 1.
+ seqOrder at: seqId put: currentSeqNum.
+ orderSeq at: currentSeqNum ifAbsentPut: [seqId].
+ code := seqCode at: seqId ifAbsentPut: [OrderedCollection new].
+ jumps at: seqId ifAbsentPut: [nil].
+ instrMap := instrMaps at: seqId ifAbsentPut: [OrderedCollection new].
+ stack := stacks at: seqId ifAbsentPut: [self initializeStackCounter]
+
+ "Modified: / 11-06-2008 / 13:58:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+popTop
+
+ stack pop.
+
+ self nextPut: #drop
+
+ "Modified: / 11-06-2008 / 14:17:22 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+pushDup
+
+ stack push.
+
+ self nextPut: #dup
+
+ "Modified: / 11-06-2008 / 14:15:10 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+pushInstVar: index
+
+ stack push.
+
+ (index between: 1 and: 10)
+ ifTrue:[self nextPut:('pushInstVar',index printString) asSymbol]
+ ifFalse:[self nextPut:#pushInstVar; nextPut: index].
+
+ "Modified: / 11-06-2008 / 14:19:57 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+pushLiteral: object
+
+ stack push.
+
+ self
+ nextPut: #pushLit;
+ nextPut: (self addLiteral: object).
+
+ "Modified: / 11-06-2008 / 14:04:41 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+pushLiteralVariable: object
+
+ stack push.
+
+ self
+ nextPut: #pushGlobalS;
+ nextPut: (self addLiteral: object)
+
+ "Modified: / 11-06-2008 / 14:13:42 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+pushReceiver
+
+ stack push.
+
+ self nextPut: #pushSelf
+
+ "Modified: / 11-06-2008 / 14:14:25 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+pushTemp: index
+
+ | instr idx |
+
+ stack push.
+ maxTemp := index max: maxTemp.
+
+ idx := index.
+ instr := index <= numArgs
+ ifTrue:[#pushMethodArg]
+ ifFalse:[idx := idx - numArgs.#pushMethodVar].
+ self
+ nextPut: instr;
+ nextPut: idx
+
+ "Modified: / 11-06-2008 / 14:46:22 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+pushThisContext
+
+ stack push.
+
+ self nextPut: #pushThisContext
+
+ "Modified: / 11-06-2008 / 14:31:32 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+remoteReturn
+
+ self saveLastJump: #return.
+
+ self send: #privRemoteReturnTo:.
+!
+
+returnConstant: obj
+
+ self saveLastJump: #return.
+
+ code size = 0 ifTrue: [
+ lastSpecialReturn := Message selector: #returnConstant: argument: obj].
+
+ obj = true ifTrue:[^self nextPut: #retTrue].
+ obj = false ifTrue:[^self nextPut: #retFalse].
+ obj = nil ifTrue:[^self nextPut: #retNil].
+ obj = 0 ifTrue:[^self nextPut: #ret0].
+
+ self pushLiteral: obj.
+ self returnTop.
+
+ "Modified: / 11-06-2008 / 14:07:40 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+returnInstVar: index
+
+ self saveLastJump: #return.
+
+ code size = 0 ifTrue: [
+ lastSpecialReturn := Message selector: #returnInstVar: argument: index].
+
+ self pushInstVar: index.
+ self returnTop.
+
+ "Modified: / 11-06-2008 / 13:56:42 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+returnReceiver
+
+ self saveLastJump: #return.
+
+ code size = 0 ifTrue: [
+ lastSpecialReturn := Message selector: #returnReceiver].
+
+ self nextPut: #retSelf
+
+ "Modified: / 11-06-2008 / 14:29:31 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+returnTop
+
+ self saveLastJump: #return.
+
+ self nextPut: #retTop
+
+ "Modified: / 11-06-2008 / 14:04:55 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+send: selector
+
+ stack pop: selector numArgs.
+
+
+ self
+ nextPut: #send;
+ nextPut: 0; "lineno"
+ nextPut: (self addLiteral: selector);
+ nextPut: selector numArgs.
+
+ "Modified: / 11-06-2008 / 14:16:58 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+send: selector toSuperOf: behavior
+
+ stack pop: selector numArgs.
+
+
+ self
+ nextPut: #superSend;
+ nextPut: 0; "lineno"
+ nextPut: (self addLiteral: selector);
+ nextPut: selector numArgs;
+ nextPut: (self addLiteral: behavior superclass)
+
+ "Modified: / 11-06-2008 / 16:10:34 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+storeInstVar: index
+
+ self
+ nextPut: #storeInstVar;
+ nextPut: index.
+
+ "Modified: / 11-06-2008 / 14:49:52 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+storeIntoLiteralVariable: object
+
+ stack pop.
+ self
+ nextPut: #storeGlobalS;
+ nextPut: (self addLiteral: object)
+
+ "Modified: / 11-06-2008 / 16:23:06 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+storeTemp: index
+
+ stack pop.
+ maxTemp := index max: maxTemp.
+
+ index <= numArgs ifTrue:[self error:'Cannot store to method argument!!'].
+
+ self
+ nextPut:#storeMethodVar;
+ nextPut:index - numArgs
+
+ "Modified: / 11-06-2008 / 16:24:28 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRBytecodeGenerator methodsFor:'mapping'!
+
+mapBytesTo: instr
+ "Associate next byte with instr"
+
+ instrMap add: instr -> (code size + 1)
+
+ "Modified: / 11-06-2008 / 13:56:42 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRBytecodeGenerator methodsFor:'old style blocks'!
+
+blockReturnTop
+
+ self saveLastJump: #return.
+
+ self nextPut: (Bytecodes at: #returnTopFromBlock).
+!
+
+fromBlock: curId goto: seqId
+
+ | distance from to |
+
+ from _ seqOrder at: curId.
+ to _ seqOrder at: seqId ifAbsent: [^ self].
+ distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i |
+ size + (seqCode at: (orderSeq at: i)) size].
+ distance > 1023 ifTrue: [self error: 'forward jump too big'].
+ self nextPut: (Bytecodes at: #longUnconditionalJump) first + (distance // 256) + 4.
+ self nextPut: distance \\ 256.
+
+ "Modified: / 11-06-2008 / 13:58:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+jumpOverBlock: seqId
+
+ stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])).
+
+
+ self saveLastJump: (Message
+ selector: #fromBlock:goto:
+ arguments: {currentSeqId. seqId}).
+
+ self fromBlock: currentSeqId goto: seqId.
+! !
+
+!IRBytecodeGenerator methodsFor:'private'!
+
+addLastLiteral: object
+
+ lastLiteral ifNil: [^ lastLiteral := object].
+ (lastLiteral = object)
+ ifFalse: [self error: 'there can only be one last literal'].
+
+ "Modified: / 11-06-2008 / 13:49:30 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+addLiteral: object
+
+ (literals includes: object)
+ ifFalse:[literals add: object].
+ ^ literals identityIndexOf: object
+
+ "Modified: / 11-06-2008 / 13:49:00 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+from: fromSeqId goto: toSeqId
+
+ | distance from to |
+ from _ seqOrder at: fromSeqId.
+ to _ seqOrder at: toSeqId ifAbsent: [^ self].
+ from + 1 = to ifTrue: [^ self]. "fall through, no jump needed"
+
+ from < to ifTrue: [ "jump forward"
+ distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i |
+ size + (seqCode at: (orderSeq at: i)) size].
+ self jumpForward: distance.
+ ] ifFalse: [ "jump backward"
+ distance _ ((to to: from - 1) inject: 0 into: [:size :i |
+ size + (seqCode at: (orderSeq at: i)) size])
+ + code size.
+ self jumpBackward: distance.
+ ].
+
+ "Modified: / 11-06-2008 / 13:58:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+from: fromSeqId if: bool goto: toSeqId otherwise: otherwiseSeqId
+
+ | distance from to otherwise |
+ from _ seqOrder at: fromSeqId.
+ to _ seqOrder at: toSeqId ifAbsent: [^ self jump: 0 if: bool]. "not done yet"
+ otherwise _ seqOrder at: otherwiseSeqId ifAbsent: [^ self jump: 0 if: bool]. "not done yet"
+ from < to ifFalse: [self errorConditionalJumpBackwards].
+ from + 1 = otherwise ifFalse: [self errorFallThroughSequenceNotNext].
+ distance _ (from + 1 to: to - 1)
+ inject: 0
+ into: [:size :i | size + (seqCode at: (orderSeq at: i)) size].
+ self jump: distance if: bool.
+
+ "Modified: / 11-06-2008 / 13:58:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+jump: distance if: condition
+
+ | |
+ distance = 0 ifTrue: [
+ "jumps to fall through, no-op"
+ ^ self popTop].
+
+ self
+ nextPut:(condition ifTrue:[#trueJump] ifFalse:[#falseJump]);
+ nextPut: distance
+
+ "Modified: / 11-06-2008 / 15:49:07 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+jumpBackward: distance
+
+ | |
+ distance = 0 ifTrue: [^ self]. "no-op"
+
+ self
+ nextPut:#jump;
+ nextPut: distance negated
+
+ "
+ dist _ 1024 - distance - 2.
+ dist < 0 ifTrue: [self error: 'back jump too big'].
+ self nextPut: (Bytecodes at: #longUnconditionalJump) first + (dist // 256).
+ self nextPut: dist \\ 256.
+ "
+
+ "Modified: / 11-06-2008 / 15:48:56 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+jumpForward: distance
+
+
+ distance = 0 ifTrue: [^ self]. "no-op"
+
+ self
+ nextPut:#jump;
+ nextPut:distance
+
+ "Modified: / 11-06-2008 / 15:26:12 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+newDummySeqId
+
+ ^ Object new
+!
+
+nextPut: byte
+
+ code add: byte
+
+ "Modified: / 11-06-2008 / 13:56:42 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+saveLastJump: message
+
+ jumps at: currentSeqId put: (Array with: code size with: message).
+
+ "Modified: / 11-06-2008 / 15:40:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+updateJump: seqId
+ "Recalculate final jump bytecodes. Return true if jump bytecodes SIZE has changed, otherwise return false"
+
+ | pair s1 |
+ pair := jumps at: seqId.
+ pair last == #return ifTrue: [^ false]. "no jump, a return"
+ code := seqCode at: seqId.
+ s1 := code size.
+ code removeLast: (code size - pair first).
+ pair last sendTo: self.
+ ^ s1 ~= code size
+
+ "Modified: / 11-06-2008 / 15:31:49 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRBytecodeGenerator methodsFor:'results'!
+
+bytecodes
+
+ ^ByteCodeCompiler new
+ genByteCodeFrom: self symboliccodes;
+ code.
+
+ "Modified: / 11-06-2008 / 14:01:32 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+compiledMethod
+
+ ^ self compiledMethodUsing: Method
+
+ "Modified: / 11-06-2008 / 14:01:51 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+compiledMethodUsing: aCompiledMethodClass
+
+ ^(aCompiledMethodClass new: literals size)
+ numberOfArgs: numArgs;
+ numberOfVars: maxTemp - numArgs ;
+ byteCode: self bytecodes;
+ literals: literals asArray;
+ yourself
+
+ "Created: / 11-06-2008 / 14:02:03 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+literals
+
+ literals := literals asArray copyWith: MethodProperties new.
+
+ ^ lastLiteral
+ ifNil: [literals copyWith: nil ]
+ ifNotNil: [literals copyWith: lastLiteral]
+!
+
+numArgs
+
+ ^ numArgs
+!
+
+numTemps
+
+ ^ maxTemp
+!
+
+relativeJumpsToAbsoluteIn: symbolicCode
+
+ symbolicCode withIndexDo:
+ [:instr :index|
+ (instr isSymbol and:[#(jump trueJump falseJump) includes: instr]) ifTrue:
+ [|offset|
+ offset := symbolicCode at: index + 1.
+ (offset > 0)
+ ifTrue:[symbolicCode at: index + 1 put: (index + offset + 2)]
+ ifFalse:[symbolicCode at: index + 1 put: (index + offset)]]].
+
+ ^symbolicCode.
+
+ "Created: / 11-06-2008 / 15:56:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+stackSize
+
+ ^ (stacks collect: [:s | s length]) max
+!
+
+symboliccodes
+
+ | stream |
+ [ orderSeq
+ inject: false
+ into: [:changed :seqId | (self updateJump: seqId) | changed]
+ ] whileTrue.
+
+ stream := (OrderedCollection new: 100) writeStream.
+ orderSeq do: [:seqId |
+ (instrMaps at: seqId) do: [:assoc |
+ assoc key "instr" bytecodeIndex: stream position + assoc value.
+ ].
+ stream nextPutAll: (seqCode at: seqId).
+ ].
+ ^self relativeJumpsToAbsoluteIn:stream contents
+
+ "Created: / 11-06-2008 / 14:00:43 / Jan Vrany <vranyj1@fel.cvut.cz>"
+ "Modified: / 11-06-2008 / 15:52:33 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRBytecodeGenerator class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRConstant.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,66 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstruction subclass:#IRConstant
+ instanceVariableNames:'constant type'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRConstant comment:'Instruction "pushLiteral: object"'
+!
+
+
+!IRConstant methodsFor:'accessing'!
+
+constant
+
+ ^ constant
+!
+
+constant: object
+
+ constant _ object
+!
+
+type
+ "type is nil, #block, or #blockMethod"
+
+ ^ type
+!
+
+type: symbol
+ "symbol is nil, #block, or #blockMethod"
+
+ type _ symbol
+! !
+
+!IRConstant methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ type == nil ifTrue:[^interpreter pushLiteral: constant].
+ type == #block ifTrue:[^interpreter pushBlock: constant].
+ type == #blockMethod ifTrue:[^interpreter pushBlockMethod: constant].
+ self shouldNeverBeReached.
+
+ "Modified: / 11-06-2008 / 01:03:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRConstant methodsFor:'testing'!
+
+isConstant
+
+ ^ true
+!
+
+isConstant: valueTest
+
+ ^ valueTest value: constant
+! !
+
+!IRConstant class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRDecompiler.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,1290 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInterpreter subclass:#IRDecompiler
+ instanceVariableNames:'stack sp scope currentInstr valueLabelMap mapEmptyStatement'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRDecompiler comment:'I interpret IRMethod instructions and generate a Smalltalk abstract syntax tree rooted at a RBMethodNode.
This is implemented like a shift-reduce parser. Each instruction either causes a node to be pushed on the stack (shift), or causes one or more nodes to be popped and combined into a single node which is push back on the stack (reduce). Most reduction is done at the "label: labelNum" instruction where it tries to reduce jump structures into control messages like #ifTrue:, whileFalse:, etc.
Several pseudo nodes (RBPseudoNode and subclasses) are used to represent basic instructions that have not been reduced to real AST nodes yet.
'
+!
+
+
+!IRDecompiler class methodsFor:'as yet unclassified'!
+
+dummySelector: numArgs
+ "Answer a dummy selector with number of args"
+
+ | sel |
+ sel _ 'unknown'.
+ 1 to: numArgs do: [:i |
+ sel _ sel, 'with:'].
+ ^ sel asSymbol
+! !
+
+!IRDecompiler methodsFor:'accessing'!
+
+scope
+
+ ^scope
+! !
+
+!IRDecompiler methodsFor:'init'!
+
+addTempToScope: ir
+
+ "Temp may be created only if they are not used in the method"
+ 0 to: ir numRargs - 1 do: [:i | (scope
+ rawVarAt: i
+ ifNone: [
+ scope capturedVars do: [:each |
+ each index = i ifTrue:[
+ scope tempVarAt: scope capturedVars size + scope tempVars size.
+ ^self]].
+ scope tempVarAt: i]) markArg]
+!
+
+decompileIR: ir
+ | sequenceNode temps args goto seq value method |
+ scope isBlockScope
+ ifTrue:[(scope addTemp: 'parent env') markArg]
+ ifFalse:[(scope addTemp: 'self') markArg].
+ ir tempKeys do: [:temp | scope tempVarAt: temp].
+ 0 to: ir numRargs - 1 do: [:i | (scope tempVarAt: i) markArg].
+ self interpret: ir.
+
+ self addTempToScope: ir.
+ self label: #return.
+ self Label: #return.
+ (self endCase: #lastReturn) ifFalse:[self Label: #return.].
+ goto := self Goto.
+ value := self ValueOrNone.
+ seq := self Sequence.
+ self removeClosureCreation: seq.
+ sp = 1 ifFalse: [stack explore. self error: 'error'].
+ value ifNotNil: [seq addNode: value].
+ sequenceNode := (self newBlock: seq return: goto) body.
+ temps := scope compactIndexTemps asArray.
+ ir tempKeys: temps.
+ args := (temps first: ir numRargs) allButFirst.
+ args := args collect: [:var | self newVar: var].
+ temps := temps allButFirst: ir numRargs.
+ sequenceNode temporaries: (temps collect: [:var | self newVar: var]),
+ ((scope capturedVars select:[:var | var name ~= 'self' and: [var sourceTemp == nil]])
+ collect:[:var | self newVar: var]).
+ method := (RBMethodNode new)
+ selectorParts: (self
+ newSelectorParts: (self class dummySelector: args size));
+ arguments: args;
+ body: sequenceNode;
+ primitiveNode: ir primitiveNode;
+ scope: scope.
+ sequenceNode parent: method.
+ Preferences compileBlocksAsClosures
+ ifFalse: [ASTFixDecompileBlockScope new visitNode: method].
+ ^ method
+!
+
+removeClosureCreation: seq
+ (Preferences compileBlocksAsClosures
+ and: [seq statements size > 0]
+ and: [seq statements first isClosureEnvironmentCreation]) ifTrue: [
+ seq statements removeFirst.
+ (seq statements size > 0
+ and: [seq statements first isClosureEnvironmentRegistration])
+ ifTrue: [seq statements removeFirst]].
+
+ [Preferences compileBlocksAsClosures
+ and: [seq statements size > 0]
+ and: [seq statements first isClosureRegistrationAndCreation
+ or: [seq statements first isSelfClosureRegistration]
+ or: [seq statements first isTempClosureRegistration]]]
+ whileTrue: [seq statements removeFirst]
+!
+
+scope: aLexicalScope
+
+ scope := aLexicalScope
+! !
+
+!IRDecompiler methodsFor:'instructions'!
+
+goto: seqNum
+
+ self stackPush: (RBPseudoGotoNode new destination: seqNum).
+!
+
+if: bool goto: seqNum1 otherwise: seqNum2
+
+ self stackPush: (RBPseudoIfNode new
+ boolean: bool;
+ destination: seqNum1;
+ otherwise: seqNum2)
+!
+
+label: seqNum
+
+ stack isEmpty ifTrue: [ "start"
+ ^ stack addLast: (RBPseudoLabelNode new destination: seqNum)].
+
+ self captureEmptyStatement.
+ "Reduce jump structures to one of the following if possible"
+ [ (self endBlock: seqNum) or: [
+ (self endAndOr: seqNum) or: [
+ (self endAndOr2: seqNum) or: [
+ (self endIfThen: seqNum) or: [
+ (self endIfThen2: seqNum) or:[
+ (self endIfThenElse: seqNum) or: [
+ (self endCase: seqNum) or: [
+ (self endToDo: seqNum) or: [
+ (self endWhile: seqNum) or: [
+ (self endWhile2: seqNum) or: [
+ (self endIfNil: seqNum)]]]]]]]]]]
+ ] whileTrue.
+
+ stack addLast: (RBPseudoLabelNode new destination: seqNum).
+!
+
+popTop
+
+ | value |
+ stack last ifNil: [^ stack removeLast]. "pop no-op from #simplifyTempAssign:"
+ [stack last isLabel
+ and: [(stack atLast:2) isGoto]
+ and: [stack last destination = (stack atLast: 2) destination]]
+ whileTrue: [
+ stack removeLast.
+ stack removeLast].
+ stack last isValue ifTrue: [
+ (stack atLast: 2) isSequence ifTrue: [
+ value := stack removeLast.
+ ^ stack last addNode: value.
+ ] ifFalse: [(stack atLast: 2) isPseudo ifTrue: [
+ value := stack removeLast.
+ ^ stack addLast: (RBSequenceNode statements: {value}).
+ ]].
+ ].
+ stack addLast: RBPseudoPopNode new
+!
+
+pushBlock: irMethod
+
+ self block: irMethod env: nil
+!
+
+pushBlockMethod: irMethod
+
+ "block will recognized when send: #createBlock:"
+ self pushLiteral: irMethod
+!
+
+pushDup
+
+ stack addLast: RBPseudoDupNode new
+!
+
+pushInstVar: index
+
+ self stackPush: (self newVar: (scope instanceScope instVar: index))
+!
+
+pushLiteral: object
+
+ self stackPush: (self newLiteral: object).
+!
+
+pushLiteralVariable: object
+
+ | var |
+ var := scope lookupVar: object key asString.
+ self stackPush: (self newVar: var)
+!
+
+pushTemp: tempIndex
+
+ | var |
+ var := scope basicTempVarAt: tempIndex.
+ var isTemp ifTrue: [var cantBeCapture].
+ self stackPush: (self newVar: var).
+!
+
+remoteReturn
+
+ stack removeLast. "pop home context free var"
+ self goto: #return.
+!
+
+returnTop
+
+ self goto: #return.
+!
+
+send: selector
+
+ | args rcvr |
+ selector = #caseError ifTrue:[^self stackPush: (RBPseudoSendNode new selector: selector)].
+ args := OrderedCollection new.
+ [ selector numArgs timesRepeat: [args addFirst: self Value].
+ rcvr := self Value.
+ ] on: Abort do: [
+ [self stackPush: (RBPseudoSendNode new selector: selector).
+ ^self cascade] on: Abort do:[^false]
+ ].
+
+ Preferences compileBlocksAsClosures
+ ifTrue: [ (rcvr isLiteral and: [selector = #createBlock:]) ifTrue: [
+ ^ self block: rcvr value env: args first]]
+ ifFalse: [ (selector = #blockCopy:) ifTrue: [
+ ^ self stackPush: (RBPseudoSendNode new selector: selector; arguments: args)]].
+
+ self stackPush: (self simplify: (RBMessageNode new
+ receiver: rcvr
+ selectorParts: (self newSelectorParts: selector)
+ arguments: args)).
+!
+
+send: selector toSuperOf: behavior
+
+ | args rcvr |
+ args _ OrderedCollection new.
+ selector numArgs timesRepeat: [args addFirst: self Value].
+ rcvr _ self Value.
+ (rcvr isVariable and: [rcvr name = 'self']) ifFalse: [self patternError].
+
+ rcvr identifierToken: (SqueakToken value: 'super' start: 0).
+ self stackPush: (RBMessageNode new
+ receiver: rcvr
+ selectorParts: (self newSelectorParts: selector)
+ arguments: args).
+!
+
+storeIntoLiteralVariable: association
+
+ | var |
+ var := scope lookupVar: association key asString.
+ self stackPush: (self simplifyTempAssign:
+ (RBAssignmentNode variable: (self newVar: (var markWrite)) value: self Value))
+!
+
+storeTemp: tempIndex
+
+ | var |
+ var := scope basicTempVarAt: tempIndex.
+ var isCaptured ifFalse: [var cantBeCapture].
+ var isTemp ifTrue:[
+ var isArg: false].
+ self stackPush: (self simplifyTempAssign:
+ (RBAssignmentNode variable: (self newVar: (var markWrite)) value: self Value)).
+! !
+
+!IRDecompiler methodsFor:'interpret'!
+
+interpretInstruction: irInstruction
+
+ currentInstr := irInstruction.
+ super interpretInstruction: irInstruction.
+!
+
+interpretSequence: instructionSequence
+
+ super interpretSequence: instructionSequence.
+ "currentInstr := nil."
+! !
+
+!IRDecompiler methodsFor:'old blocks'!
+
+blockReturnTop
+
+ self goto: #return.
+!
+
+endBlock: seqNum
+
+ | blockSeq block goto startBlock |
+ [
+ goto := self GotoOrReturn: seqNum.
+ (goto isRet
+ or:[goto mapInstr notNil
+ and: [goto mapInstr isBlockReturnTop]]) ifFalse: [self abort].
+ sp = 0 ifTrue: [self abort].
+ blockSeq := self Sequence2.
+ startBlock := self Label.
+ block := self Block.
+ (goto isRet not
+ and:[goto mapInstr notNil]
+ and: [goto mapInstr isBlockReturnTop]
+ and: [block successor ~= seqNum]) ifTrue:[
+ self stackPush: block.
+ self stackPush: startBlock.
+ self stackPush: blockSeq.
+ self stackPush: goto.
+ self abort].
+ self Send.
+ ] on: Abort do: [^ false].
+
+ self stackPush: (self newBlock: blockSeq return: goto).
+ stack last arguments: block arguments.
+ "No extra scope is need if we don't use any temporaries and arguments.
+ so we remove them"
+ (stack last arguments isEmpty and: [stack last body temporaries isEmpty])
+ ifTrue:[ASTReplaceVariableScope replace: stack last scope: scope outerScope ].
+ scope := scope outerScope.
+ currentInstr := nil.
+ self goto: block successor.
+ ^ true
+!
+
+jumpOverBlock: seqNum1 to: seqNum2
+ | numArgs args oldscope pseudoBlock |
+
+ oldscope := scope.
+ self scope: (scope newBlockScope).
+ oldscope tempVarAt: 0.
+ (scope addObjectTemp: (oldscope tempVarAt: 0)).
+ numArgs := stack last arguments first value.
+ self stackPush: (pseudoBlock := RBPseudoBlockNode new).
+
+ args := OrderedCollection new.
+ numArgs timesRepeat: [ | var instr |
+ instr := currentInstr blockSequence removeFirst.
+ var := oldscope tempVarAt: instr number.
+ args add: (self newVar: var).
+ var isUnused ifTrue: [oldscope removeTempFromOldBlock: var].
+ scope addObjectTemp: var.
+ currentInstr blockSequence first isPop
+ ifFalse: [
+ currentInstr blockSequence sequence addFirst: (IRInstruction pushTemp: var index)]
+ ifTrue:[currentInstr blockSequence removeFirst].
+
+ ].
+ args := args reverse.
+ pseudoBlock
+ block: seqNum1;
+ successor: seqNum2;
+ arguments: args
+
+!
+
+storeInstVar: number
+
+ | var |
+ var := scope instanceScope instVar: number.
+ self stackPush: (RBAssignmentNode variable: (self newVar: var) value: self Value)
+! !
+
+!IRDecompiler methodsFor:'priv instructions'!
+
+addReturn: statements from: goto
+
+ | ret |
+ statements last isReturn ifTrue:[^self].
+ ret := RBReturnNode value: statements last.
+ Preferences compileBlocksAsClosures ifTrue:[
+ scope isHome ifFalse: [ret homeBinding: scope outerEnvScope thisEnvVar]].
+ goto mapInstr sourceNode: ret.
+ statements atLast: 1 put: ret.
+!
+
+block: method env: envRefNode
+
+ self stackPush: (IRDecompiler new
+ scope: (scope newBlockScope "capturedVars: vars");
+ decompileIR: method ir)
+ asBlock
+!
+
+cascade
+
+ | messages selector args rcvr |
+ messages := OrderedCollection new.
+ "last message"
+ selector _ self Send selector.
+ args := OrderedCollection new.
+ selector numArgs timesRepeat: [args addFirst: self Value].
+ messages addFirst: selector -> args.
+
+ "rest of messages"
+ [(rcvr := self ValueOrNone) isNil] whileTrue: [
+ self Pop.
+ selector := self Send selector.
+ args := OrderedCollection new.
+ selector numArgs timesRepeat: [args addFirst: self Value].
+ self Dup.
+ messages addFirst: selector -> args.
+ ].
+
+ messages := messages collect: [:assoc |
+ RBMessageNode
+ receiver: rcvr
+ selector: assoc key
+ arguments: assoc value].
+ self stackPush: (RBCascadeNode messages: messages).
+!
+
+endAndOr2: seqNum
+
+ | goto seq p if2 test else o if1 seqValue elseTest otherwise |
+ [
+ goto _ self Goto.
+ seqValue _ self ValueOrNone.
+ seq _ self Sequence.
+ p _ self Label destination.
+ if2 _ self IfGoto: seqNum otherwise: p.
+ elseTest _ self Value.
+ else _ self SequenceBackTo: goto destination.
+ o _ self Label destination.
+ o = goto destination ifTrue: [self abort].
+ if1 _ self IfGoto: seqNum otherwise: o.
+ test _ self Value.
+ ] on: Abort do: [^ false].
+
+ if1 boolean = if2 boolean
+ ifFalse: [
+ otherwise := RBSequenceNode statements: #().
+ otherwise addNode: (self newLiteral: if2 boolean).
+ self stackPush: (RBMessageNode
+ receiver: test
+ selector: (if2 boolean ifTrue: [#ifTrue:ifFalse:] ifFalse: [#ifFalse:ifTrue:])
+ arguments: {self newBlock: (else addNode: elseTest).
+ self newBlock: otherwise}).]
+ ifTrue:[self stackPush: (RBMessageNode
+ receiver: test
+ selector: (if2 boolean ifTrue: [#or:] ifFalse: [#and:])
+ arguments: {self newBlock: (else addNode: elseTest)})].
+ stack addLast: if2.
+ self label: p.
+ stack addLast: seq.
+ seqValue ifNotNil: [stack addLast: seqValue].
+ stack addLast: goto.
+ ^ true
+!
+
+endAndOr: seqNum
+
+ | o test branches if body block sel1 sel2 if2 |
+ branches := OrderedCollection new.
+ [
+ (if2 := self If) otherwise = seqNum ifFalse: [self abort].
+ [ test := self Value.
+ body := self Sequence.
+ branches add: {body. test}.
+ o := self Label destination.
+ (if := self If) otherwise = o ifFalse: [self abort].
+ if destination = seqNum
+ ] whileFalse: [
+ if boolean = if2 boolean ifFalse: [self abort].
+ if destination = if2 destination ifFalse: [self abort].
+ ].
+ if boolean = if2 boolean ifTrue: [self abort].
+ test := self Value.
+ ] on: Abort do: [^ false].
+
+ if boolean
+ ifTrue: [sel1 := #or:. sel2 := #and:]
+ ifFalse: [sel1 := #and:. sel2 := #or:].
+ block := self newBlock: (branches first first addNode: branches first second).
+ branches allButFirstDo: [:pair |
+ block := self newBlock: (pair first addNode: (RBMessageNode
+ receiver: pair second
+ selector: sel2
+ arguments: {block})).
+ ].
+ self stackPush: (RBMessageNode
+ receiver: test
+ selector: sel1
+ arguments: {block}).
+ stack addLast: if2.
+ ^ true
+!
+
+endCase: seqNum
+
+ | otherwiseGoto goto node otherwiseValue otherwiseSeq n branchValue branchSeq f caseValue caseSeq rcvr branches message seqEnd afterOterwise seq afterOterwiseValue |
+ branches := OrderedCollection new.
+ [ "otherwise"
+ otherwiseGoto := self Goto.
+ node := self stackDown.
+ node isSequence ifTrue: [(node statements size = 1
+ and:[node statements first isSend]
+ and: [
+ node := node statements first.
+ node selector == #caseError]) ifFalse: [
+ otherwiseSeq := node] ].
+ (node isPop or: [node isSend and: [node selector == #caseError]]) ifTrue: [
+ node isPop ifTrue: [node := self Send].
+ node selector == #caseError ifFalse: [self abort].
+ ] ifFalse: [
+ sp := sp + 1. "stackUp"
+
+ seqNum == #lastReturn
+ ifFalse: [
+ otherwiseValue := self ValueOrNone.
+ otherwiseSeq := self Sequence]
+ ifTrue: [
+ afterOterwiseValue := self ValueOrNone.
+ otherwiseSeq := RBSequenceNode statements: #().
+ afterOterwise := self SequenceOtherwise].
+ ].
+ n := self Label destination.
+ "last case branch"
+ seqNum == #lastReturn
+ ifFalse: [goto := self GotoOrReturn: seqNum]
+ ifTrue: [
+ seqEnd := n.
+ goto := self GotoOrReturn: n.
+ otherwiseGoto := goto].
+ branchValue := self ValueOrNone.
+ branchSeq := self Sequence.
+ (stack at: sp) isPop ifTrue: [self stackDown].
+ f := self Label destination.
+
+ "last case"
+ self IfGoto: n otherwise: f.
+ self Send selector == #= ifFalse: [self abort].
+ caseValue := self Value.
+ caseSeq := self Sequence.
+ otherwiseSeq ifNil: [self Dup].
+ branches addFirst: ({caseSeq. caseValue} -> {branchSeq. branchValue. goto}).
+
+ [(rcvr := self ValueOrNone) isNil] whileTrue: [
+ "case branch"
+ n := self Label destination.
+ seqNum == #lastReturn
+ ifFalse: [goto := self GotoOrReturn: seqNum]
+ ifTrue: [goto := self GotoOrReturn: seqEnd].
+ branchValue := self ValueOrNone.
+ branchSeq := self Sequence.
+ self Pop.
+ f := self Label destination.
+ "case"
+ self IfGoto: n otherwise: f.
+ self Send selector == #= ifFalse: [self abort].
+ caseValue := self Value.
+ caseSeq := self Sequence.
+ self Dup.
+ branches addFirst: ({caseSeq. caseValue} -> {branchSeq. branchValue. goto}).
+ ].
+ ] on: Abort do: [^ false].
+
+ branches := branches collect: [:assoc |
+ assoc key second
+ ifNotNil: [assoc key first addNode: assoc key second].
+ assoc value second
+ ifNotNil: [assoc value first addNode: assoc value second].
+ RBMessageNode
+ receiver: (self newBlock: assoc key first return: nil)
+ selector: #->
+ arguments:
+ {self newBlock: assoc value first return: assoc value third}
+ ].
+ message := otherwiseSeq
+ ifNil: [
+ RBMessageNode
+ receiver: rcvr
+ selector: #caseOf:
+ arguments: {RBArrayNode statements: branches}]
+ ifNotNil: [
+ otherwiseValue
+ ifNotNil: [otherwiseSeq addNode: otherwiseValue].
+ RBMessageNode
+ receiver: rcvr
+ selector: #caseOf:otherwise:
+ arguments:
+ {RBArrayNode statements: branches.
+ self newBlock: otherwiseSeq return: otherwiseGoto}.
+ ].
+ self stackPush: message.
+ seqNum == #lastReturn ifTrue: [
+ self popTop.
+ seq := self Sequence.
+ afterOterwise ifNotNil:[seq statements addAllLast: afterOterwise statements].
+ self stackPush: seq.
+ afterOterwiseValue ifNotNil:[self stackPush: afterOterwiseValue].
+ branchValue := 1].
+ branchValue ifNil: [self popTop].
+ self stackPush: otherwiseGoto.
+ ^ true
+!
+
+endIfNil: seqNum
+
+ | goto branch o if rcvr value |
+ [
+ goto := self Goto.
+ value := self Value.
+ branch := self Sequence.
+ self Pop.
+ o := self Label destination.
+ if := self IfGoto: seqNum otherwise: o.
+ self Send selector == #== ifFalse: [self abort].
+ (self Value isLiteral: [:v | v isNil]) ifFalse: [self abort].
+ self Dup.
+ rcvr := self Value.
+ ] on: Abort do: [^ false].
+
+ branch addNode: value.
+ self stackPush: (RBMessageNode
+ receiver: rcvr
+ selector: (if boolean ifTrue: [#ifNotNil:] ifFalse: [#ifNil:])
+ arguments: {self newBlock: branch return: goto}).
+ self goto: seqNum.
+ ^ true
+!
+
+endIfThen2: seqNum
+
+ | goto branch o if test value gotoNum branch2 |
+ [
+ goto := self Goto.
+ (goto mapInstr ~= nil
+ and: [goto mapInstr isJump]
+ and: [goto mapInstr destination size = 1]
+ and: [goto mapInstr destination last isJump])
+ ifTrue: [gotoNum := goto
+ mapInstr destination last destination orderNumber]
+ ifFalse:[self abort].
+ (currentInstr ~= nil
+ and: [currentInstr isJump]
+ and: [currentInstr destination orderNumber = goto destination])
+ ifFalse: [self abort].
+ value := self Value.
+ branch := self Sequence.
+ o := self Label destination.
+ seqNum = gotoNum
+ ifFalse:[if := self IfGoto: gotoNum otherwise: o]
+ ifTrue:[self abort].
+ test := self Value.
+ ] on: Abort do: [^ false].
+
+ value ifNotNil: [branch addNode: value].
+ branch2 := RBSequenceNode statements: #().
+ branch2 addNode: (self newLiteral: if boolean).
+ self stackPush: (self simplify: (RBMessageNode
+ receiver: test
+ selector: (if boolean ifTrue: [#ifFalse:ifTrue:] ifFalse: [#ifTrue:ifFalse:])
+ arguments: {self newBlock: branch return: goto.
+ self newBlock: branch2})).
+ self goto: goto destination.
+ ^true
+!
+
+endIfThen3: seqNum
+
+ | goto branch o if test value |
+ [
+ goto := self Goto.
+ (goto destination == seqNum or: [self isExplicitReturn: goto])
+ ifFalse: [self abort].
+ goto isRet ifTrue: [value := self Value].
+ branch := self Sequence.
+ o := self Label destination.
+ if := self If.
+ ((if destination = seqNum
+ or: [if destination = (mapEmptyStatement at: seqNum ifAbsent:[seqNum])])
+ and: [if otherwise = o])
+ ifFalse:[self abort].
+ test := self Value.
+ ] on: Abort do: [^ false].
+
+
+ value ifNotNil: [branch addNode: value].
+ self stackPush: (self simplify: (RBMessageNode
+ receiver: test
+ selector: (if boolean ifTrue: [#ifFalse:] ifFalse: [#ifTrue:])
+ arguments: {self newBlock: branch return: goto})).
+ self popTop.
+ self goto: seqNum.
+ ^ true
+!
+
+endIfThen: seqNum
+
+ | goto branch o if test value |
+ [
+ goto := self Goto.
+ (goto destination == seqNum or: [self isExplicitReturn: goto])
+ ifFalse: [self abort].
+ goto isRet ifTrue: [value := self Value].
+ branch := self Sequence.
+ o := self Label destination.
+ if := self IfGoto: seqNum otherwise: o.
+ test := self Value.
+ ] on: Abort do: [^ false].
+
+
+ value ifNotNil: [branch addNode: value].
+ self stackPush: (self simplify: (RBMessageNode
+ receiver: test
+ selector: (if boolean ifTrue: [#ifFalse:] ifFalse: [#ifTrue:])
+ arguments: {self newBlock: branch return: goto})).
+ self popTop.
+ self goto: seqNum.
+ ^ true
+!
+
+endIfThenElse: seqNum
+
+ | goto2 else d goto1 then o if test value2 value1 |
+ [
+ goto2 := self Goto.
+ value2 := self ValueOrNone.
+ else := self Sequence.
+ d := self Label destination.
+ goto1 := self Goto.
+ ((self isExplicitReturn: goto2) or: [goto2 destination == goto1 destination]) ifFalse: [self abort].
+ value1 := self ValueOrNone.
+ then := self Sequence.
+ o := self Label destination.
+ if := self IfGoto: d otherwise: o.
+ test := self Value.
+ ] on: Abort do: [^ false].
+
+ value2 ifNotNil: [else addNode: value2].
+ value1 ifNotNil: [then addNode: value1].
+ (self isExplicitReturn: goto1) ifTrue:[self addReturn: then statements from: goto1].
+ (self isExplicitReturn: goto2) ifTrue:[self addReturn: else statements from: goto2].
+ self stackPush: (self simplify: (else isEmpty
+ ifTrue: [RBMessageNode
+ receiver: test
+ selector: (if boolean ifTrue: [#ifFalse:] ifFalse: [#ifTrue:])
+ arguments: {self newBlock: then return: goto1}]
+ ifFalse: [RBMessageNode
+ receiver: test
+ selector: (if boolean
+ ifTrue: [#ifFalse:ifTrue:]
+ ifFalse: [#ifTrue:ifFalse:])
+ arguments: {
+ self newBlock: then return: goto1.
+ self newBlock: else return: goto2}])).
+ value1 ifNil: [self popTop].
+ currentInstr := goto1 mapInstr.
+ self stackPush: goto1.
+ (else statements isEmpty and:
+ [stack anySatisfy: [:n | n isIf and: [n destination = d]]]
+ ) ifTrue: [
+ self label: d.
+ currentInstr := goto2 mapInstr.
+ self stackPush: goto2.
+ ].
+ ^ true
+!
+
+endToDo: seqNum
+
+ | start limit incr iter step loopBlock o if test limitExpr init |
+ [
+ start := self Goto destination.
+ limit := self Value.
+ incr := self Assignment.
+ iter := incr variable.
+ (incr value isMessage and:
+ [incr value selector == #+ and:
+ [incr value receiver isVariable and:
+ [incr value receiver binding == iter binding]]]
+ ) ifFalse: [self abort].
+ step := incr value arguments first.
+ loopBlock := self Sequence.
+ o := self Label destination.
+ if := self IfGoto: seqNum otherwise: o.
+ test := self Value.
+ (test isMessage and:
+ [(test selector == #<= or: [test selector == #>=]) and:
+ [(valueLabelMap at: test arguments first ifAbsent: [self abort]) destination = start]]
+ ) ifFalse: [self abort].
+ limitExpr := test arguments first.
+ limitExpr isAssignment ifTrue: [
+ (limitExpr variable binding index == limit binding index
+ and:[limitExpr variable binding scope == limit binding scope]) ifFalse: [self abort].
+ limitExpr := limitExpr value.
+ ].
+ init := test receiver.
+ (init isAssignment and: [init variable binding == iter binding])
+ ifFalse: [self abort].
+ ] on: Abort do: [^ false].
+ limit isVariable
+ ifTrue:[scope
+ removeTemp: limit binding
+ ifAbsent:[Preferences compileBlocksAsClosures
+ ifFalse:[scope removeTempFromOldBlock: limit]]].
+ loopBlock := self newBlock: loopBlock.
+ loopBlock arguments: {iter}.
+ self stackPush: ((step isLiteral: [:c | c = 1])
+ ifTrue: [RBMessageNode
+ receiver: init value
+ selector: #to:do:
+ arguments: {limitExpr. loopBlock}]
+ ifFalse: [RBMessageNode
+ receiver: init value
+ selector: #to:by:do:
+ arguments: {limitExpr. step. loopBlock}]).
+ self popTop.
+ self goto: seqNum.
+ ^ true
+!
+
+endWhile2: seqNum
+
+ | start loopBlock if test sequence o goto previousStack |
+ [
+ stack := (previousStack := stack) copy.
+ start := (goto := self Goto) destination.
+ self stackPush: goto.
+ [self endIfThen3: start] whileTrue.
+ start := self Goto destination.
+ loopBlock _ self Sequence.
+ o _ self Label destination.
+ if _ self IfGoto: seqNum otherwise: o.
+ test _ self Value.
+ sequence _ self SequenceBackTo: start.
+ self Label: start.
+ sp _ sp + 1. "stackUp"
+ ] on: Abort do: [stack := previousStack. ^ false].
+ loopBlock isEmpty
+ ifTrue:[self stackPush: (self simplify: (RBMessageNode
+ receiver: (self newBlock: (sequence addNode: test))
+ selector: (if boolean ifTrue: [#whileFalse] ifFalse: [#whileTrue])
+ arguments: #()))]
+ ifFalse:[self stackPush: (self simplify: (RBMessageNode
+ receiver: (self newBlock: (sequence addNode: test))
+ selector: (if boolean ifTrue: [#whileFalse:] ifFalse: [#whileTrue:])
+ arguments: {self newBlock: loopBlock}))].
+ self popTop.
+ self goto: seqNum.
+ ^ true
+!
+
+endWhile: seqNum
+
+ | start loopBlock if test sequence o |
+ [
+ start _ self Goto destination.
+ loopBlock _ self Sequence.
+ o _ self Label destination.
+ if _ self IfGoto: seqNum otherwise: o.
+ test _ self Value.
+ sequence _ self SequenceBackTo: start.
+ self Label: start.
+ sp _ sp + 1. "stackUp"
+ ] on: Abort do: [^ false].
+ loopBlock isEmpty
+ ifTrue:[self stackPush: (self simplify: (RBMessageNode
+ receiver: (self newBlock: (sequence addNode: test))
+ selector: (if boolean ifTrue: [#whileFalse] ifFalse: [#whileTrue])
+ arguments: #()))]
+ ifFalse:[self stackPush: (self simplify: (RBMessageNode
+ receiver: (self newBlock: (sequence addNode: test))
+ selector: (if boolean ifTrue: [#whileFalse:] ifFalse: [#whileTrue:])
+ arguments: {self newBlock: loopBlock}))].
+ self popTop.
+ self goto: seqNum.
+ ^ true
+! !
+
+!IRDecompiler methodsFor:'private'!
+
+captureEmptyStatement
+ | by replace node |
+
+ [by := self Goto destination.
+ replace := self Label destination.
+ replace = 0 ifTrue: [self abort]]
+ on: Abort
+ do: [^ false].
+ mapEmptyStatement at: by put: replace.
+ sp := nil.
+ ^ true
+!
+
+fixInnerFreeVar: aRcvrTemp
+
+ | scopeInnerFreeVar |
+ scopeInnerFreeVar := scope outerScope.
+ [aRcvrTemp scope = scopeInnerFreeVar] whileFalse:[
+ scopeInnerFreeVar hasInnerFreeVars: true.
+ scopeInnerFreeVar := scopeInnerFreeVar outerScope].
+ aRcvrTemp scope hasInnerFreeVars: true
+!
+
+initialize
+
+ stack := OrderedCollection new.
+ scope := nil parseScope newMethodScope. "in case never set"
+ valueLabelMap := IdentityDictionary new.
+ mapEmptyStatement := IdentityDictionary new
+!
+
+isExplicitReturn: goto
+
+ Preferences compileBlocksAsClosures
+ ifTrue:[^ goto isRet
+ and: [goto mapInstr notNil]
+ and: [goto mapInstr isRemote or: [scope isBlockScope not]]]
+ ifFalse: [^goto isRet and: [goto mapInstr isBlockReturnTop not]]
+!
+
+mapNode: node
+
+ currentInstr ifNil: [^ self].
+ node isPseudo
+ ifTrue: [node mapInstr: currentInstr]
+ ifFalse: [currentInstr sourceNode: node]
+!
+
+newBlock: sequence
+
+ ^ self newBlock: sequence return: nil
+!
+
+newBlock: sequence return: goto
+
+ | statements block |
+ statements := sequence statements.
+ (goto notNil and: [self isExplicitReturn: goto]) ifTrue: [
+ self addReturn: statements from: goto
+ ].
+ sequence statements: statements.
+ block := RBBlockNode body: sequence.
+ sequence parent: block.
+ Preferences compileBlocksAsClosures ifFalse: [block scope: scope].
+ ^block
+!
+
+newLiteral: literal
+
+ ^ RBLiteralNode value: literal
+!
+
+newSelectorParts: selector
+
+ ^ selector keywords collect: [:word |
+ RBLiteralToken value: word]
+!
+
+newVar: semVar
+
+ ^ RBVariableNode new
+ identifierToken: (RBIdentifierToken value: semVar name start: 0);
+ binding: semVar
+!
+
+simplify: mess
+ "mess is a messageNode. If it is a message created by the compiler convert it back to its normal form"
+
+ | rcvr var |
+" (mess selector == #value and: [mess receiver isLiteral]) ifTrue: [
+ ^ self newVar: (GlobalVar new assoc: mess receiver value; scope: scope)
+ ]."
+
+ (mess selector = #privSetInHolder: and: [mess arguments first isLiteral]) ifTrue: [
+ ^ RBAssignmentNode
+ variable: (self newVar: (GlobalVar new assoc: mess arguments first value; scope: scope) markWrite)
+ value: mess receiver
+ ].
+
+ (mess selector = #privGetInstVar: and:
+ [mess arguments first isLiteral and:
+ [mess receiver isVariable]]) ifTrue: [
+ rcvr := mess receiver binding.
+ rcvr == scope receiverVar ifTrue: [
+ ^ self newVar: (scope receiverVarAt: mess arguments first value)].
+ (rcvr isContextVar and: [mess arguments first value == 5]) ifTrue: [
+ var := scope tempVarAt: -1.
+ ^self newVar: var].
+ (rcvr isCaptured and:[rcvr sourceTemp = rcvr scope receiverVar])
+ ifTrue:[
+ self fixInnerFreeVar: rcvr.
+ ^self newVar: (rcvr scope receiverVarAt: mess arguments first value)].
+ rcvr isEnv ifTrue: [^self newVar: (rcvr scope captureVarAt: mess arguments first value)]].
+
+ (mess selector = #privStoreIn:instVar: and:
+ [mess arguments last isLiteral and:
+ [mess arguments first isVariable]]) ifTrue: [
+ rcvr := mess arguments first binding.
+ (mess receiver name = 'self' and: [rcvr isEnv])
+ ifTrue:[scope captureSelf: mess arguments last value.
+ ^mess].
+ rcvr == scope receiverVar ifTrue: [^ RBAssignmentNode
+ variable: (self newVar: (scope receiverVarForAssignmentAt: mess arguments last value) markWrite)
+ value: mess receiver].
+ (rcvr isCaptured and:[rcvr sourceTemp = rcvr scope receiverVar])
+ ifTrue:[
+ self fixInnerFreeVar: rcvr.
+ ^RBAssignmentNode
+ variable: (self newVar: (rcvr scope receiverVarForAssignmentAt: mess arguments last value) markWrite)
+ value: mess receiver].
+ mess isClosureEnvironmentRegistration
+ ifTrue: [
+ scope captureSelf: mess arguments last value.
+ ^mess].
+ rcvr isEnv ifTrue:[
+ mess receiver isTemp
+ ifTrue:[var := (scope
+ captureVarAt: mess arguments last value
+ sourceTemp: mess receiver binding) markWrite.]
+ ifFalse:[var := (scope
+ captureVarAt: mess arguments last value sourceTemp: ((TempVar new)
+ name: (scope captureVarName: mess arguments last value);
+ index: mess arguments last value;
+ scope: self;
+ cantBeCapture)) markWrite
+ ].
+ ^ RBAssignmentNode
+ variable: (self newVar: var)
+ value: mess receiver]].
+ ^mess
+!
+
+simplifyTempAssign: assignment
+ "If it is a assignment created by the compiler convert it back to its normal form"
+
+ | mess |
+ ((mess := assignment value) isMessage and:
+ [mess selector = #wrapInTempHolder and:
+ [mess receiver isLiteral: [:v | v isNil]]]
+ ) ifTrue: [
+ ^ nil "no-op"
+ ].
+
+ ^ assignment
+! !
+
+!IRDecompiler methodsFor:'stack'!
+
+Assignment
+
+ | node |
+ (node := self stackDown) isAssignment ifTrue: [^ node].
+ self abort
+!
+
+Block
+
+ | node |
+ (node := self stackDown) isBlock ifTrue: [^ node].
+ self abort
+!
+
+Dup
+
+ | node |
+ (node := self stackDown) isDup ifTrue: [^ node].
+ self abort
+!
+
+Goto
+
+ | node |
+ (node := self stackDown) isGoto ifTrue: [^ node].
+ self abort
+!
+
+Goto: seqNum
+
+ | goto |
+ (goto := self Goto) destination = seqNum ifTrue: [^ goto].
+ self abort
+!
+
+GotoOrReturn: seqNum
+
+ | goto |
+ goto := self Goto.
+ (goto destination = seqNum or: [goto isRet]) ifTrue: [^ goto].
+ self abort
+!
+
+If
+
+ | node |
+ (node := self stackDown) isIf ifTrue: [^ node].
+ self abort
+!
+
+IfGoto: seqNum otherwise: seqNum2
+
+ | if |
+ ((if := self If) destination = seqNum and: [if otherwise = seqNum2])
+ ifTrue: [^ if].
+ self abort
+!
+
+Label
+
+ | node |
+ (node := self stackDown) isLabel ifTrue: [^ node].
+ self abort
+!
+
+Label: seqNum
+
+ | label |
+ (label := self Label) destination = seqNum ifTrue: [^ label].
+ self abort
+!
+
+Pop
+
+ | node |
+ (node := self stackDown) isPop ifTrue: [^ node].
+ self abort
+!
+
+Send
+
+ | node |
+ (node := self stackDown) isPseudoSend ifTrue: [^ node].
+ self abort
+!
+
+Sequence
+ | node seq i goto |
+ seq := RBSequenceNode statements: #().
+ i := self spIndex.
+ [node := stack at: i.
+ node isSequence
+ ifTrue:
+ [seq addNodesFirst: node statements.
+ node := stack at: (i := i - 1)].
+ (node isLabel and: [i > 1])
+ ifFalse:
+ [sp := i.
+ ^ seq].
+ goto := stack at: (i := i - 1).
+ goto isGoto and: [goto destination = node destination]]
+ whileTrue: [i := i - 1].
+ sp := i + 1.
+ ^ seq
+!
+
+Sequence2
+ | node seq i block temps label |
+ seq := RBSequenceNode statements: #().
+ i := self spIndex.
+ node := stack at: i.
+ [(node isLabel and: [(stack at: i - 1) isGoto] and:[node destination = (stack at: i - 1) destination])
+ ifTrue:[
+ i := i - 2.
+ node := stack at: i].
+ (node isLabel not and: [i > 1])] whileTrue:
+ [
+ node isSequence
+ ifTrue: [seq addNodesFirst: node statements]
+ ifFalse: [seq addNodeFirst: node].
+ i := i - 1.
+ node := stack at: i].
+ sp := i.
+ label := self Label.
+ block := self Block.
+ self stackPush: block.
+ self stackPush: label.
+ "Add the temporaries find"
+ temps := scope tempVars asArray allButFirst.
+ temps := temps select: [:each | ((block arguments
+ collect: [:var | var binding]) includes: each) not].
+ seq temporaries: (temps collect: [:var | self newVar: var]).
+ ^ seq
+!
+
+SequenceBackTo: labelNum
+ | node seq i goto |
+ seq := RBSequenceNode statements: #().
+ i := self spIndex.
+ [node := stack at: i.
+ node isSequence
+ ifTrue:
+ [seq addNodesFirst: node statements.
+ node := stack at: (i := i - 1)].
+ (node isLabel and: [i > 1])
+ ifFalse:
+ [sp := i.
+ ^ seq].
+ node destination = labelNum
+ ifTrue:
+ [sp := i.
+ ^ seq].
+ goto := stack at: (i := i - 1).
+ goto isGoto and: [goto destination = node destination]]
+ whileTrue: [i := i - 1].
+ sp := i + 1.
+ ^ seq
+!
+
+SequenceOtherwise
+ | node seq i |
+ seq := RBSequenceNode statements: #().
+ i := self spIndex.
+ node := stack at: i.
+ node isSequence ifTrue: [
+ seq addNodesFirst: node statements.
+ self stackDown]
+ ifFalse:[node isLabel ifFalse:[self abort]].
+ ^ seq
+!
+
+Value
+
+ | node |
+ node := self ValueOrNone.
+ node ifNil: [self abort].
+ ^ node
+!
+
+ValueOrNone
+ | node i label |
+ i := self spIndex.
+ [node := stack at: i.
+ node isValue
+ ifTrue:
+ [label ifNotNil: [valueLabelMap at: node put: label].
+ sp := i - 1.
+ ^ node].
+ (node isLabel and: [i > 1]) ifFalse: [^ nil].
+ label := node.
+ node := stack at: (i := i - 1).
+ node isGoto and: [node destination = label destination]]
+ whileTrue: [i := i - 1].
+ ^ nil
+!
+
+abort
+
+ | spWas |
+ spWas := sp.
+ sp := nil.
+ Abort signal
+!
+
+fixStack
+
+ sp ifNotNil: [stack removeLast: (stack size - sp)].
+ sp := nil.
+!
+
+spIndex
+ ^ sp ifNil: [sp := stack size]
+!
+
+stackDown
+
+ | node |
+ sp ifNil: [sp _ stack size].
+ sp = 0 ifTrue: [self abort].
+ node _ stack at: sp.
+ sp _ sp - 1.
+ ^ node
+!
+
+stackPush: node
+
+ self fixStack.
+ stack addLast: node.
+ node ifNil: [^ self]. "no op"
+ self mapNode: node.
+! !
+
+!IRDecompiler class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRDup.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,25 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstruction subclass:#IRDup
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRDup comment:'Instruction "pushDup"'
+!
+
+
+!IRDup methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ ^ interpreter pushDup
+! !
+
+!IRDup class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRInstVarAccess.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,29 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRAccess subclass:#IRInstVarAccess
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRInstVarAccess comment:'when closures disabled, Field describes an instVar. With closures, it describes a
fieldaccess with receiver to be accessed pushed first.'
+!
+
+
+!IRInstVarAccess methodsFor:'testing'!
+
+isInstVarAccess
+ ^true.
+!
+
+varname
+ name ifNil: [name := self method compiledMethod methodClass allInstVarNames at: self offset].
+ ^name.
+! !
+
+!IRInstVarAccess class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRInstVarRead.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,34 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstVarAccess subclass:#IRInstVarRead
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRInstVarRead methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ interpreter pushInstVar: number
+
+ "Modified: / 11-06-2008 / 13:17:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRInstVarRead methodsFor:'testing'!
+
+isRead
+ ^true.
+!
+
+isStore
+ ^false.
+! !
+
+!IRInstVarRead class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRInstVarStore.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,36 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstVarAccess subclass:#IRInstVarStore
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRInstVarStore methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ Preferences compileBlocksAsClosures
+ ifFalse: [interpreter storeInstVar: number]
+ ifTrue: [interpreter pushLiteral: number.
+ interpreter send: #privStoreIn:instVar:].
+
+! !
+
+!IRInstVarStore methodsFor:'testing'!
+
+isRead
+ ^false
+!
+
+isStore
+ ^true
+! !
+
+!IRInstVarStore class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRInstruction.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,354 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+Link subclass:#IRInstruction
+ instanceVariableNames:'sourceNode bytecodeIndex sequence'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRInstruction comment:'I am an instruction in the IR (intermediate representation) language. The IR serves as the intermediary between the Smalltalk language and the bytecode language. It is easier to optimize and translate to/from this language than it is to optimize/translate directly from Smalltalk to bytecodes. The IR is generic and simple consisting of just twelve instructions. They are:
goto: labelNum
if: boolean goto: labelNum1 otherwise: labelNum2
label: labelNum
popTop
pushDup
pushLiteral: object
pushBlock: irMethod
pushBlockMethod: irMethod
pushTemp: tempIndex
remoteReturn
returnTop
send: selector
send: selector toSuperOf: behavior
storeTemp: tempIndex
Each instruction is reified as an instance of one of my eight subclasses and grouped by basic block (IRSequence) into an IRMethod. IRInterpreter visits each instruction in a IRMethod responding to the above instruction messages sent to it.
'
+!
+
+
+!IRInstruction class methodsFor:'instance creation'!
+
+goto: seq
+
+ ^ IRJump new
+ destination: seq
+!
+
+if: bool goto: seq1 otherwise: seq2
+
+ ^ IRJumpIf new
+ boolean: bool;
+ destination: seq1;
+ otherwise: seq2
+!
+
+new
+ ^super basicNew.
+!
+
+popTop
+
+ ^ IRPop new
+!
+
+pushBlock: irMethod
+
+ ^ IRConstant new
+ constant: irMethod;
+ type: #block
+!
+
+pushBlockMethod: irMethod
+
+ ^ IRConstant new
+ constant: irMethod;
+ type: #blockMethod
+!
+
+pushDup
+
+ ^ IRDup new
+!
+
+pushInstVar: index
+
+ ^ IRInstVarRead new number: index.
+!
+
+pushLiteral: object
+
+ ^ IRConstant new
+ constant: object
+!
+
+pushLiteralVariable: object
+
+ ^ IRLiteralVariableRead new
+ association: object.
+
+!
+
+pushReceiver
+ ^IRInstruction pushTemp: 0
+!
+
+pushTemp: index
+
+ ^ IRTempRead new
+ number: index.
+!
+
+pushThisContext
+ ^IRInstruction pushTemp: -2
+!
+
+remoteReturn
+
+ ^ IRReturn new
+ isRemote: true
+!
+
+returnTop
+
+ ^ IRReturn new
+ isRemote: false
+!
+
+send: selector
+
+ ^ IRSend new
+ selector: selector
+!
+
+send: selector toSuperOf: behavior
+
+ behavior ifNil: [self error: 'super of nil does not exist'].
+ ^ IRSend new
+ selector: selector;
+ superOf: behavior
+!
+
+storeInstVar: index
+
+ ^ IRInstVarStore new number: index.
+
+!
+
+storeIntoLiteralVariable: object
+
+ ^ IRLiteralVariableStore new
+ association: object
+!
+
+storeTemp: index
+
+ ^ IRTempStore new
+ number: index.
+! !
+
+!IRInstruction class methodsFor:'instance creation - old style blocks'!
+
+blockReturnTop
+
+ ^ IRBlockReturnTop new
+
+!
+
+jumpOverBlock: block to: cont
+ ^ (IRJumpOverBlock new)
+ blockSequence: block;
+ destination: cont.
+! !
+
+!IRInstruction methodsFor:'accessing'!
+
+method
+ ^sequence method.
+!
+
+sequence
+ ^sequence
+!
+
+sequence: aSeq
+ sequence := aSeq
+!
+
+successorSequences
+ "sent to last instruction in sequence which is expected to be a jump and return instruction"
+
+ ^ #()
+! !
+
+!IRInstruction methodsFor:'adding'!
+
+addInstructionsAfter: aCollection
+ sequence addInstructions: aCollection after: self.
+!
+
+addInstructionsBefore: aCollection
+ sequence addInstructions: aCollection before: self.
+! !
+
+!IRInstruction methodsFor:'interpret'!
+
+executeOn: interpreter
+ "Send approriate message to interpreter"
+
+ self subclassResponsibility
+! !
+
+!IRInstruction methodsFor:'mapping'!
+
+bytecodeIndex
+
+ ^ bytecodeIndex
+!
+
+bytecodeIndex: index
+
+ bytecodeIndex _ index
+!
+
+bytecodeOffset
+ | startpc |
+ startpc := self method compiledMethod initialPC.
+ self bytecodeIndex ifNil: [^startpc].
+ ^self bytecodeIndex + startpc - 1.
+!
+
+sourceNode
+
+ ^ sourceNode
+
+!
+
+sourceNode: parseNode
+
+ sourceNode _ parseNode
+
+! !
+
+!IRInstruction methodsFor:'replacing'!
+
+delete
+ sequence isNil ifTrue: [self error: 'This node doesn''t have a sequence'].
+ sequence remove: self.
+!
+
+replaceNode: aNode withNode: anotherNode
+ self error: 'I don''t store other nodes'
+!
+
+replaceWith: aNode
+ sequence isNil ifTrue: [self error: 'This node doesn''t have a sequence'].
+ sequence replaceNode: self withNode: aNode
+!
+
+replaceWithInstructions: aCollection
+
+ sequence isNil ifTrue: [self error: 'This node doesn''t have a sequence'].
+ sequence replaceNode: self withNodes: aCollection
+! !
+
+!IRInstruction methodsFor:'testing'!
+
+isBlockReturnTop
+ ^false
+!
+
+isConstant
+
+ ^ false
+!
+
+isConstant: valueTest
+
+ ^ false
+!
+
+isGoto
+ "is unconditional jump"
+
+ ^ false
+!
+
+isIf
+
+ ^ false
+!
+
+isInBlock
+ | irs |
+ irs := self method allInstructionsMatching: [:each | each isJumpOverBlock ].
+ irs detect: [:each | each blockSequence == self sequence ] ifNone: [^false].
+ ^true
+!
+
+isInstVarAccess
+ ^false.
+!
+
+isInstVarRead
+ ^self isInstVarAccess and: [self isRead].
+!
+
+isInstVarStore
+ ^self isInstVarAccess and: [self isStore].
+!
+
+isJump
+ "goto or if"
+
+ ^ false
+!
+
+isJumpOrReturn
+
+ ^ self isJump or: [self isReturn]
+!
+
+isJumpOverBlock
+ ^false
+!
+
+isLiteralVariable
+ ^false
+!
+
+isLiteralVariableAccess
+ ^false
+!
+
+isLiteralVariableRead
+ ^false
+!
+
+isLiteralVariableStore
+ ^false
+!
+
+isPop
+
+ ^ false
+!
+
+isReturn
+
+ ^ false
+!
+
+isSelf
+ ^false
+!
+
+isSend
+ ^false.
+!
+
+isTemp
+ ^false
+!
+
+isTempAccess
+ ^false
+!
+
+isTempRead
+ ^false
+!
+
+isTempStore
+ ^false
+! !
+
+!IRInstruction class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRInterpreter.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,100 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+Object subclass:#IRInterpreter
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRInterpreter comment:'I visit each IRInstruction in an IRMethod in order. Each instruction sends its instruction message to me upon being visited. See my ''instructions'' method category for complete list of instructions. Subclasses should override them.'
+!
+
+
+!IRInterpreter methodsFor:'instructions'!
+
+blockReturnTop
+!
+
+goto: seqNum
+!
+
+if: bool goto: seqNum1 otherwise: seqNum2
+!
+
+jumpOverBlock: blockSeq to: dest
+!
+
+label: seqNum
+!
+
+popTop
+!
+
+pushBlock: irMethod
+!
+
+pushBlockMethod: irMethod
+!
+
+pushDup
+!
+
+pushInstVar: aSmallInteger
+!
+
+pushLiteral: object
+!
+
+pushLiteralVariable: object
+!
+
+pushTemp: index
+!
+
+remoteReturn
+!
+
+returnTop
+!
+
+send: selector
+!
+
+send: selector toSuperOf: behavior
+!
+
+storeLiteralVariable: index
+!
+
+storeTemp: index
+! !
+
+!IRInterpreter methodsFor:'interpret'!
+
+interpret: ir
+
+ self interpretAll: ir allSequences
+!
+
+interpretAll: irSequences
+
+ irSequences do: [:seq | self interpretSequence: seq]
+!
+
+interpretInstruction: irInstruction
+
+ irInstruction executeOn: self
+!
+
+interpretSequence: instructionSequence
+
+ self label: instructionSequence orderNumber.
+ instructionSequence do: [:instr | self interpretInstruction: instr].
+! !
+
+!IRInterpreter class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRJump.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,56 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstruction subclass:#IRJump
+ instanceVariableNames:'destination'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRJump comment:'Instruction "goto: labelNum"'
+!
+
+
+!IRJump methodsFor:'accessing'!
+
+destination
+
+ ^ destination
+!
+
+destination: aSequence
+
+ destination := aSequence
+!
+
+successorSequences
+
+ ^ {destination}
+! !
+
+!IRJump methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ ^ interpreter goto: destination orderNumber
+! !
+
+!IRJump methodsFor:'testing'!
+
+isGoto
+ "is unconditional jump"
+
+ ^ true
+!
+
+isJump
+ "goto or if"
+
+ ^ true
+! !
+
+!IRJump class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRJumpIf.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,65 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRJump subclass:#IRJumpIf
+ instanceVariableNames:'boolean otherwise'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRJumpIf comment:'Instruction "if: boolean goto: labelNum1 otherwise: labelNum2"'
+!
+
+
+!IRJumpIf methodsFor:'acessing'!
+
+boolean
+
+ ^ boolean
+!
+
+boolean: bool
+
+ boolean _ bool
+!
+
+otherwise
+
+ ^ otherwise
+!
+
+otherwise: aSequence
+
+ otherwise := aSequence
+!
+
+successorSequences
+
+ ^ {destination. otherwise}
+! !
+
+!IRJumpIf methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ ^ interpreter if: boolean goto: destination orderNumber otherwise: otherwise orderNumber
+! !
+
+!IRJumpIf methodsFor:'testing'!
+
+isGoto
+ "is unconditional jump"
+
+ ^ false
+!
+
+isIf
+
+ ^ true
+! !
+
+!IRJumpIf class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRJumpOverBlock.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,44 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRJump subclass:#IRJumpOverBlock
+ instanceVariableNames:'blockSequence'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRJumpOverBlock methodsFor:'accessing'!
+
+blockSequence
+ ^blockSequence
+!
+
+blockSequence: instr
+ blockSequence := instr.
+!
+
+successorSequences
+
+ ^ Array with: destination with: blockSequence
+
+ "Modified: / 11-06-2008 / 13:31:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRJumpOverBlock methodsFor:'interpret'!
+
+executeOn: interpreter
+ ^ interpreter jumpOverBlock: blockSequence orderNumber to: destination orderNumber
+! !
+
+!IRJumpOverBlock methodsFor:'testing'!
+
+isJumpOverBlock
+ ^true.
+! !
+
+!IRJumpOverBlock class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRLiteralVariableAccess.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,37 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRAccess subclass:#IRLiteralVariableAccess
+ instanceVariableNames:'association'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRLiteralVariableAccess methodsFor:'accessing'!
+
+association: anAssociation
+ association := anAssociation
+!
+
+isLiteralVariable
+ ^true
+!
+
+isLiteralVariableAccess
+ ^true
+!
+
+isLiteralVariableRead
+ ^self isLiteralVariableAccess and: [self isRead].
+!
+
+isLiteralVariableStore
+ ^self isLiteralVariableAccess and: [self isStore].
+! !
+
+!IRLiteralVariableAccess class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRLiteralVariableRead.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,31 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRLiteralVariableAccess subclass:#IRLiteralVariableRead
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRLiteralVariableRead methodsFor:'interpret'!
+
+executeOn: interpreter
+ interpreter pushLiteralVariable: association
+! !
+
+!IRLiteralVariableRead methodsFor:'testing'!
+
+isRead
+ ^true
+!
+
+isStore
+ ^false
+! !
+
+!IRLiteralVariableRead class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRLiteralVariableStore.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,31 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRLiteralVariableAccess subclass:#IRLiteralVariableStore
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRLiteralVariableStore methodsFor:'interpret'!
+
+executeOn: interpreter
+ interpreter storeIntoLiteralVariable: association
+! !
+
+!IRLiteralVariableStore methodsFor:'testing'!
+
+isRead
+ ^false
+!
+
+isStore
+ ^true
+! !
+
+!IRLiteralVariableStore class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRMethod.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,344 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+Object subclass:#IRMethod
+ instanceVariableNames:'startSequence primitiveNode tempKeys numRargs compiledMethod
+ properties additionalLiterals maxOrderNumber sourceMap'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRMethod comment:'I am a method in the IR (intermediate representation) language consisting of IRInstructions grouped by IRSequence (basic block). The IRSequences form a control graph (therefore I only have to hold onto the starting sequence). #compiledMethod will convert me to a CompiledMethod. #methodNode will convert me back to a parse tree.
'
+!
+
+
+!IRMethod class methodsFor:'instance creation'!
+
+new
+ ^ self basicNew initialize.
+
+ "Created: / 11-06-2008 / 00:52:34 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRMethod methodsFor:'accessing'!
+
+addLiteral: aSymbol
+
+ additionalLiterals add: aSymbol.
+!
+
+addLiterals: anArray
+
+ additionalLiterals addAll: anArray.
+!
+
+addTemps: newKeys
+
+ tempKeys addAll: newKeys.
+!
+
+additionalLiterals
+ ^additionalLiterals.
+!
+
+allInstructions
+ " return irNodes as a flat collection "
+
+ | irInstructions |
+ irInstructions := OrderedCollection new.
+ startSequence withAllSuccessorsDo: [:seq | seq do: [:bc | irInstructions add: bc]].
+ ^irInstructions
+!
+
+allInstructionsMatching: aBlock
+ " return irNodes as a flat collection "
+
+ | irInstructions |
+ irInstructions := OrderedCollection new.
+ startSequence withAllSuccessorsDo: [:seq | seq do: [:bc | (aBlock value: bc) ifTrue: [irInstructions add: bc]]].
+ ^irInstructions
+!
+
+allSendInstructions
+ ^self allInstructionsMatching: [:bc | bc isSend].
+!
+
+allSequences
+
+ ^ startSequence withAllSuccessors
+!
+
+allTempAccessInstructions
+ ^self allInstructionsMatching: [:bc | bc isTempAccess].
+!
+
+allTempReadInstructions
+ ^self allInstructionsMatching: [:bc | bc isTempRead].
+!
+
+allTempWriteInstructions
+ ^self allInstructionsMatching: [:bc | bc isTempStore].
+!
+
+ir
+ ^self.
+!
+
+method
+ ^self.
+!
+
+numArgs
+
+ ^ self numRargs - 1
+!
+
+numRargs
+
+ ^ numRargs
+!
+
+primitiveNode
+
+ ^ primitiveNode
+!
+
+properties
+ ^properties
+!
+
+properties: propDict
+ properties := propDict.
+!
+
+startSequence
+
+ ^ startSequence
+!
+
+tempKeys
+
+ ^ tempKeys
+!
+
+tempNames
+ "All temp names in context order"
+
+ | varNames |
+ varNames _ OrderedCollection new.
+ self tempKeys do: [:var | | name |
+ name _ var asString.
+ "vars are unique but inlined to:do: loop vars may have the same name, so munge the names to make them different"
+ [varNames includes: name] whileTrue: [name _ name, 'X'].
+ varNames add: name.
+ ].
+ ^ varNames asArray
+! !
+
+!IRMethod methodsFor:'debugging support'!
+
+inspector2TabIRCode
+
+ ^Tools::Inspector2Tab new
+ label: 'IR Code';
+ priority: 75;
+ view: ((ScrollableView for:TextView) contents: self longPrintString; yourself)
+
+ "Created: / 11-06-2008 / 01:05:16 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRMethod methodsFor:'decompiling'!
+
+ast
+
+ ^ IRDecompiler new decompileIR: self
+! !
+
+!IRMethod methodsFor:'initialize'!
+
+initialize
+
+ primitiveNode := PrimitiveNode primitiveNumber: 0.
+ tempKeys := OrderedCollection new.
+ properties := Dictionary new.
+ additionalLiterals := OrderedCollection new.
+
+ "Modified: / 11-06-2008 / 00:55:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+numRargs: n
+
+ numRargs _ n
+!
+
+primitiveNode: aPrimitiveNode
+
+ primitiveNode _ aPrimitiveNode
+!
+
+startSequence: irSequence
+
+ startSequence _ irSequence.
+ irSequence method: self.
+!
+
+tempKeys: objects
+
+ tempKeys _ objects
+! !
+
+!IRMethod methodsFor:'inlining'!
+
+addInstructionsAfter: aCollection
+ | returningSeqs lastInstr |
+ aCollection ifEmpty: [^self].
+ returningSeqs := self allSequences select: [:each | each last isReturn].
+ lastInstr := returningSeqs last last.
+ lastInstr addInstructionsBefore: aCollection.
+
+!
+
+addInstructionsBefore: aCollection
+
+ (self startSequence nextSequence first) addInstructionsBefore: aCollection.
+
+!
+
+methodForInlining
+ ^self removeReturnSelf removeEmptyStart.
+!
+
+removeReturn
+ self allSequences last removeLast.
+!
+
+removeReturnSelf
+ self removeReturn.
+ self allSequences last removeLast.
+! !
+
+!IRMethod methodsFor:'mapping'!
+
+sourceMap
+ "Return a mapping from bytecode pcs to source code ranges"
+
+ | start map |
+ "Besides getting start position, make sure bytecodeIndices are filled in"
+ start _ self compiledMethod initialPC - 1.
+ map _ OrderedCollection new.
+ self allSequences do: [:seq |
+ seq do: [:instr | | node |
+ ((node _ instr sourceNode) notNil and:
+ [node debugHighlightStart notNil and:
+ [node debugHighlightStop notNil and:
+ [instr bytecodeIndex notNil]]]) ifTrue: [
+ map add:
+ instr bytecodeIndex + start
+ -> (node debugHighlightStart to: node debugHighlightStop)]
+ ]
+ ].
+ ^ map
+! !
+
+!IRMethod methodsFor:'optimizing'!
+
+absorbConstantConditionalJumps
+
+ startSequence absorbConstantConditionalJumps: IdentitySet new
+!
+
+absorbJumpsToSingleInstrs
+
+ startSequence absorbJumpToSingleInstr: IdentitySet new
+!
+
+absorbSinglePredecessor
+ | predecessor |
+ startSequence
+ detectSinglePredecessor: (predecessor := IdentityDictionary new)
+ seen: IdentitySet new.
+ startSequence collapseSinglePredecessor: predecessor seen: IdentitySet new
+!
+
+maxOrderNumber
+ maxOrderNumber ifNil: [
+ maxOrderNumber := self startSequence orderNumber.
+ self startSequence withAllSuccessorsDo: [:seq | maxOrderNumber := maxOrderNumber max: seq orderNumber].
+ ].
+ ^ maxOrderNumber.
+!
+
+newSeq
+ maxOrderNumber _ self maxOrderNumber +1.
+ ^ IRSequence new orderNumber:maxOrderNumber
+!
+
+optimize
+ self removeEmptyStart.
+ self absorbJumpsToSingleInstrs.
+ self absorbConstantConditionalJumps.
+ self absorbJumpsToSingleInstrs
+!
+
+removeEmptyStart
+
+ startSequence size = 1 ifTrue: [
+ "startSeq is just unconditional jump, forget it"
+ startSequence _ startSequence last destination].
+! !
+
+!IRMethod methodsFor:'printing'!
+
+longPrintOn: stream
+
+ IRPrinter new
+ indent: 0;
+ stream: stream;
+ interpret: self
+!
+
+longPrintString
+
+ | s |
+ s := String new writeStream.
+ self longPrintOn: s.
+ ^s contents.
+
+ "Created: / 11-06-2008 / 01:05:53 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRMethod methodsFor:'testing'!
+
+isSend
+ ^false.
+! !
+
+!IRMethod methodsFor:'translating'!
+
+compiledMethod
+
+ ^ compiledMethod ifNil: [self compiledMethodUsing: Method]
+
+ "Modified: / 11-06-2008 / 11:06:51 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+compiledMethodUsing: aCompiledMethodClass
+
+ ^ compiledMethod := IRTranslator new
+ interpret: self;
+ compiledMethodUsing: aCompiledMethodClass
+
+ "Created: / 11-06-2008 / 11:06:28 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+setCompiledMethod:aCompiledMethod
+ compiledMethod := aCompiledMethod
+
+ "Created: / 11-06-2008 / 11:05:57 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRMethod class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRPop.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,31 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstruction subclass:#IRPop
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRPop comment:'Instruction "popTop"'
+!
+
+
+!IRPop methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ ^ interpreter popTop
+! !
+
+!IRPop methodsFor:'testing'!
+
+isPop
+ ^true
+! !
+
+!IRPop class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRPrinter.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,170 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInterpreter subclass:#IRPrinter
+ instanceVariableNames:'stream indent'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRPrinter comment:'I interpret IRMethod instructions and write them out to a print stream.'
+!
+
+
+!IRPrinter methodsFor:'initialize'!
+
+indent: tabs
+
+ indent _ tabs
+!
+
+stream: stringWriteStream
+
+ stream _ stringWriteStream
+! !
+
+!IRPrinter methodsFor:'instructions'!
+
+blockReturnTop
+
+ stream nextPutAll: 'blockReturnTop'.
+!
+
+goto: seqNum
+
+ stream nextPutAll: 'goto: '.
+ seqNum printOn: stream.
+!
+
+if: bool goto: seqNum1 otherwise: seqNum2
+
+ stream nextPutAll: 'if: '.
+ bool printOn: stream.
+ stream nextPutAll: ' goto: '.
+ seqNum1 printOn: stream.
+ stream nextPutAll: ' else: '.
+ seqNum2 printOn: stream.
+!
+
+jumpOverBlock: blockSeq to: dest
+
+ stream nextPutAll: 'jumpOverBlock: '.
+ stream nextPutAll: ' block '.
+ blockSeq printOn: stream.
+ stream nextPutAll: ' cont: '.
+ dest printOn: stream.
+!
+
+label: seqNum
+
+ "add tab and cr since this does not get called within interpretInstruction:"
+ stream cr. "extra cr just to space out sequences"
+ indent timesRepeat: [stream tab].
+ stream nextPutAll: 'label: '.
+ seqNum printOn: stream.
+ stream cr.
+!
+
+popTop
+
+ stream nextPutAll: 'popTop'
+!
+
+pushBlock: irMethod
+
+ stream nextPutAll: 'pushBlock:'.
+ IRPrinter new
+ indent: indent + 1;
+ stream: stream;
+ interpret: irMethod removeEmptyStart.
+!
+
+pushBlockMethod: irMethod
+
+ stream nextPutAll: 'pushBlockMethod:'.
+ IRPrinter new
+ indent: indent + 1;
+ stream: stream;
+ interpret: irMethod removeEmptyStart.
+!
+
+pushDup
+
+ stream nextPutAll: 'pushDup'
+!
+
+pushLiteral: object
+
+ stream nextPutAll: 'pushLiteral: '.
+ object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
+ object printOn: stream.
+
+ ((object isKindOf: BlockClosure) or: [object isKindOf: CompiledMethod])
+ ifTrue: [
+ IRPrinter new
+ indent: indent + 1;
+ stream: stream;
+ interpret: object method ir removeEmptyStart].
+!
+
+pushLiteralVariable: object
+
+ stream nextPutAll: 'pushLiteralVariable: '.
+ object isVariableBinding ifTrue: [^ stream nextPutAll: object key].
+ object printOn: stream.
+!
+
+pushTemp: index
+
+ stream nextPutAll: 'pushTemp: '.
+ index printOn: stream.
+ index = 0 ifTrue: [stream nextPutAll: ' "receiver"'].
+ index = -1 ifTrue: [stream nextPutAll: ' "thisEnv"'].
+ index = -2 ifTrue: [stream nextPutAll: ' "thisContext"'].
+!
+
+remoteReturn
+
+ stream nextPutAll: 'remoteReturn'.
+!
+
+returnTop
+
+ stream nextPutAll: 'returnTop'.
+!
+
+send: selector
+
+ stream nextPutAll: 'send: '.
+ selector printOn: stream.
+!
+
+send: selector toSuperOf: behavior
+
+ stream nextPutAll: 'send: '.
+ selector printOn: stream.
+ stream nextPutAll: ' toSuperOf: '.
+ behavior printOn: stream.
+!
+
+storeTemp: index
+
+ stream nextPutAll: 'storeTemp: '.
+ index printOn: stream.
+ index = -1 ifTrue: [stream nextPutAll: ' "thisEnv"'].
+! !
+
+!IRPrinter methodsFor:'interpret'!
+
+interpretInstruction: irInstruction
+
+ indent timesRepeat: [stream tab].
+ super interpretInstruction: irInstruction.
+ stream cr.
+! !
+
+!IRPrinter class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRReturn.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,46 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstruction subclass:#IRReturn
+ instanceVariableNames:'isRemote'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRReturn comment:'Instruction "returnTop" or "remoteReturn"'
+!
+
+
+!IRReturn methodsFor:'accessing'!
+
+isRemote
+
+ ^ isRemote
+!
+
+isRemote: boolean
+
+ isRemote := boolean
+! !
+
+!IRReturn methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ ^ isRemote
+ ifTrue: [interpreter remoteReturn]
+ ifFalse: [interpreter returnTop]
+! !
+
+!IRReturn methodsFor:'testing'!
+
+isReturn
+
+ ^ true
+! !
+
+!IRReturn class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRSend.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,66 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInstruction subclass:#IRSend
+ instanceVariableNames:'selector superOf'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRSend comment:'Instruction "send: selector" or "send: selector toSuperOf: behavior"'
+!
+
+
+!IRSend methodsFor:'accessing'!
+
+selector
+ ^selector
+!
+
+selector: symbol
+
+ selector _ symbol
+!
+
+senderselector
+ ^self method selector
+!
+
+superOf
+
+ ^ superOf
+!
+
+superOf: behavior
+
+ superOf _ behavior
+! !
+
+!IRSend methodsFor:'interpret'!
+
+executeOn: interpreter
+
+ ^ superOf
+ ifNil: [interpreter send: selector]
+ ifNotNil: [interpreter send: selector toSuperOf: superOf]
+! !
+
+!IRSend methodsFor:'testing'!
+
+isMessageSend
+ ^true.
+!
+
+isSend
+ ^true.
+!
+
+isSuperSend
+ ^superOf notNil
+! !
+
+!IRSend class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRSequence.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,411 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+Object subclass:#IRSequence
+ instanceVariableNames:'sequence orderNumber method'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRSequence class methodsFor:'instance creation'!
+
+new
+ ^ self basicNew initialize.
+
+ "Created: / 11-06-2008 / 00:52:39 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRSequence methodsFor:'accessing'!
+
+after: o
+ ^sequence after: o
+!
+
+at: index
+ ^sequence at: index
+!
+
+first
+ ^sequence first
+!
+
+last
+ ^sequence last
+!
+
+method
+
+ ^method
+!
+
+method: aIRMethod
+
+ method := aIRMethod
+!
+
+orderNumber
+ "Sequences are sorted by this number"
+
+ ^ orderNumber
+!
+
+orderNumber: num
+ "Sequences are sorted by this number"
+
+ orderNumber := num.
+!
+
+sequence
+ ^sequence
+!
+
+size
+ ^sequence size.
+! !
+
+!IRSequence methodsFor:'adding'!
+
+add: anInstruction
+
+ sequence add: anInstruction.
+ anInstruction sequence: self.
+ ^anInstruction.
+!
+
+add: instr after: another
+
+ sequence add: instr after: another.
+ instr sequence: self.
+ ^instr.
+!
+
+add: instr before: another
+ sequence add: instr before: another.
+ instr sequence: self.
+ ^instr.
+!
+
+addAll: aCollection
+ ^sequence addAll: aCollection
+!
+
+addAllFirst: aCollection
+ ^sequence addAllFirst: aCollection.
+!
+
+addInstructions: aCollection
+
+ ^aCollection do: [:instr | self add: instr].
+!
+
+addInstructions: aCollection after: anInstruction
+
+ ^aCollection reverseDo: [:instr | self add: instr after: anInstruction].
+!
+
+addInstructions: aCollection before: anInstruction
+
+ aCollection do: [:instr | self add: instr before: anInstruction].
+!
+
+addLast: anInstruction
+ ^self add: anInstruction.
+! !
+
+!IRSequence methodsFor:'copying'!
+
+, otherCollection
+ ^sequence, otherCollection
+! !
+
+!IRSequence methodsFor:'enumerating'!
+
+detect: aBlock
+ ^sequence detect: aBlock
+!
+
+do: aBlock
+ ^sequence do: aBlock.
+!
+
+reverseDo: aBlock
+ ^sequence reverseDo: aBlock.
+!
+
+select: aBlock
+ ^sequence select: aBlock.
+! !
+
+!IRSequence methodsFor:'initialize-release'!
+
+initialize
+ sequence := OrderedCollection new.
+! !
+
+!IRSequence methodsFor:'manipulating'!
+
+setSuccessor: suc
+ "find the blockReturnTops, set successor "
+
+ self withAllSuccessorsDo: [:succ | succ notEmpty ifTrue: [
+ | last |
+ last := succ last.
+ last isBlockReturnTop ifTrue: [
+ last successor: suc.
+ ]
+ ]].
+!
+
+splitAfter: instruction
+
+ | newSeq index next |
+ next := self nextSequence.
+ next := next
+ ifNil: [self orderNumber + 1]
+ ifNotNil: [(next orderNumber + self orderNumber) / 2].
+ newSeq := self class new orderNumber: next.
+ newSeq method: self method.
+ "Split after instruction"
+ index := sequence indexOf: instruction.
+ (sequence last: sequence size - index) do: [:instr | newSeq add: instr].
+ sequence := sequence first: index.
+ sequence add: (IRJump new destination: newSeq).
+ ^ newSeq
+!
+
+splitAfterNoJump: instruction
+
+ | newSeq next index |
+ next := self nextSequence.
+ next := next
+ ifNil: [self orderNumber + 1]
+ ifNotNil: [(next orderNumber + self orderNumber) / 2].
+ newSeq := self class new orderNumber: next.
+ newSeq method: self method.
+
+ "Split after instruction"
+ index := sequence indexOf: instruction.
+ (sequence last: sequence size - index) do: [:instr | newSeq add: instr].
+ sequence := sequence first: index.
+
+ ^ newSeq
+!
+
+tranformToBlockSequence
+ | last |
+ " fix: if last jump --> follow jumps, remove returns and add blockReturnTop on leafs."
+
+ self withAllSuccessorsDo: [:succ |
+ succ notEmpty ifTrue: [
+ last := succ last.
+ last isJump ifFalse: [
+ last isReturn ifTrue: [succ removeLast].
+ succ addLast: IRInstruction blockReturnTop.
+ ]
+ ].
+ succ ifEmpty: [succ addLast: IRInstruction blockReturnTop].
+ ].
+! !
+
+!IRSequence methodsFor:'optimizing'!
+
+absorbConstantConditionalJumps: alreadySeen
+ "Collapse sequences that look like:
+ [if] goto s1
+ ...
+ s1: pushConst: true/false
+ goto s2
+ s2: if true/false goto s3 else s4
+ into:
+ [if] goto s3/s4
+
+ These sequences are produced by and:/or: messages"
+
+ | seq bool if |
+ (alreadySeen includes: self) ifTrue: [^ self].
+ alreadySeen add: self.
+
+ [(seq := self successorSequences) size > 0 "not return"
+ and: [(seq := seq first "destination") size = 2
+ and: [(seq first isConstant: [:obj | (bool := obj) isKindOf: Boolean])
+ and: [seq last isGoto
+ and: [(if := seq last destination first) isIf]]]]
+ ] whileTrue: [ "absorb"
+ self last destination: (bool == if boolean
+ ifTrue: [if destination]
+ ifFalse: [if otherwise]).
+ ].
+
+ self successorSequences do: [:instrs | instrs absorbConstantConditionalJumps: alreadySeen].
+!
+
+absorbJumpToSingleInstr: alreadySeen
+ "Collapse jumps to single return instructions into caller"
+
+ | seqs seq |
+ (alreadySeen includes: self) ifTrue: [^ self].
+ alreadySeen add: self.
+
+ [ (seqs := self successorSequences) size = 1 "unconditional jump..."
+ and: [(seq := seqs first) size = 1 "...to single instruction..."
+ and: [seq successorSequences size < 2
+ and: [self last isBlockReturnTop not]]] "...but don't collapse conditional jumps so their otherwiseSequences can stay right after them"
+ ] whileTrue: [ "replace goto with single instruction"
+ self removeLast.
+ seq do: [:instr | self add: instr copy].
+ ].
+
+ seqs do: [:instrs | instrs absorbJumpToSingleInstr: alreadySeen].
+
+ "Modified: / 11-06-2008 / 13:28:06 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+collapseSinglePredecessor: predecessorList seen: alreadySeen
+
+ | seqs seq |
+ (alreadySeen includes: self) ifTrue: [^ self].
+ alreadySeen add: self.
+ [(seqs := self successorSequences) size = 1
+ and: [(predecessorList at: (seq := seqs first) ifAbsent:[0]) = 1]
+ and: [seq orderNumber > self orderNumber]]
+ whileTrue:[
+ self removeLast.
+ seq do: [:instr | self add: instr copy]].
+
+ seqs do: [:instrs | instrs collapseSinglePredecessor: predecessorList seen: alreadySeen].
+!
+
+detectSinglePredecessor: sequencesPredecessor seen: alreadySeen
+
+ | seqs |
+ (alreadySeen includes: self) ifTrue: [^ self].
+ alreadySeen add: self.
+ seqs := self successorSequences.
+ seqs do: [:seq | sequencesPredecessor
+ at: seq
+ put: (sequencesPredecessor at: seq ifAbsent:[0]) + 1].
+
+ seqs do: [:instrs | instrs detectSinglePredecessor: sequencesPredecessor seen: alreadySeen].
+! !
+
+!IRSequence methodsFor:'printing'!
+
+longPrintOn: stream
+
+ [IRPrinter new
+ indent: 0;
+ stream: stream;
+ interpretSequence: self
+ ] onDNU: #orderNumber do: [:ex | ex resume: ex receiver]
+!
+
+printOn: stream
+
+ stream nextPutAll: 'an '.
+ self class printOn: stream.
+ stream space.
+ stream nextPut: $(.
+ self orderNumber printOn: stream.
+ stream nextPut: $).
+! !
+
+!IRSequence methodsFor:'removing'!
+
+removeFirst
+ ^sequence removeFirst.
+!
+
+removeLast
+ ^sequence removeLast.
+! !
+
+!IRSequence methodsFor:'replacing'!
+
+remove: aNode
+ aNode sequence: nil.
+ sequence remove: aNode ifAbsent: [self error].
+!
+
+replaceNode: aNode withNode: anotherNode
+
+ self add: anotherNode before: aNode.
+ sequence remove: aNode ifAbsent: [self error].
+!
+
+replaceNode: aNode withNodes: aCollection
+
+ self addInstructions: aCollection before: aNode.
+ sequence remove: aNode ifAbsent: [self error].
+! !
+
+!IRSequence methodsFor:'successor sequences'!
+
+instructionsDo: aBlock
+
+ ^self withAllSuccessorsDo: [:seq | seq do: aBlock].
+!
+
+nextSequence
+
+ | sequences i |
+ sequences := self withAllSuccessors.
+ i := sequences findFirst: [:seq | seq orderNumber = self orderNumber].
+ (i = 0 or: [i = sequences size]) ifTrue: [^ nil].
+ ^ sequences at: i + 1
+!
+
+successorSequences
+
+ sequence isEmpty ifTrue: [^ #()].
+ ^ sequence last successorSequences
+!
+
+withAllSuccessors
+ "Return me and all my successors sorted by sequence orderNumber"
+
+ | list |
+ list := OrderedCollection new: 20.
+ self withAllSuccessorsDo: [:seq | list add: seq].
+ ^ list asSortedCollection: [:x :y | x orderNumber <= y orderNumber]
+!
+
+withAllSuccessorsDo: block
+ "Iterate over me and all my successors only once"
+
+ self withAllSuccessorsDo: block alreadySeen: IdentitySet new
+!
+
+withAllSuccessorsDo: block alreadySeen: set
+ "Iterate over me and all my successors only once"
+
+ (set includes: self) ifTrue: [^ self].
+ set add: self.
+ block value: self.
+ self successorSequences do: [:seq |
+ seq ifNotNil: [seq withAllSuccessorsDo: block alreadySeen: set]].
+! !
+
+!IRSequence methodsFor:'testing'!
+
+ifEmpty: aBlock
+ ^sequence ifEmpty: aBlock
+!
+
+ifNotEmpty: aBlock
+ ^sequence ifNotEmpty: aBlock
+!
+
+isEmpty
+ ^sequence isEmpty
+!
+
+notEmpty
+ ^sequence notEmpty
+! !
+
+!IRSequence class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRStackCount.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,125 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+Object subclass:#IRStackCount
+ instanceVariableNames:'start position length'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-Bytecode'
+!
+
+IRStackCount comment:'This keeps track of the stack count for the BytecodeGenerator.'
+!
+
+
+!IRStackCount class methodsFor:'instance creation'!
+
+new
+
+ ^ super new startAt: 0
+! !
+
+!IRStackCount class methodsFor:'as yet unclassified'!
+
+startAt: pos
+
+ ^ super new startAt: pos
+! !
+
+!IRStackCount methodsFor:'affecting'!
+
+pop
+
+ ^ self pop: 1
+!
+
+pop: n
+
+ (position _ position - n) "< 0
+ ifTrue: [self error: 'Parse stack underflow']"
+!
+
+push
+
+ ^ self push: 1
+!
+
+push: n
+
+ (position _ position + n) > length
+ ifTrue: [length _ position]
+! !
+
+!IRStackCount methodsFor:'comparing'!
+
+= other
+
+ ^ self class == other class
+ and: [start = other start
+ and: [position = other position
+ and: [length = other size]]]
+!
+
+hash
+
+ ^ position hash bitXor: (length hash bitXor: start hash)
+! !
+
+!IRStackCount methodsFor:'error handling'!
+
+errorStackOutOfSync: aStackCount
+ self error: 'stack not in sync!!'.
+! !
+
+!IRStackCount methodsFor:'initialize'!
+
+startAt: pos
+
+ start _ position _ length _ pos
+! !
+
+!IRStackCount methodsFor:'printing'!
+
+printOn: aStream
+
+ super printOn: aStream.
+ aStream
+ nextPutAll: ' start '; print: start;
+ nextPutAll: ' stop '; print: position;
+ nextPutAll: ' max '; print: length.
+! !
+
+!IRStackCount methodsFor:'results'!
+
+length
+
+ ^length
+!
+
+linkTo: stackOrNil
+
+ stackOrNil ifNil: [^ self class startAt: self position].
+ ^ self position = stackOrNil start
+ ifTrue: [stackOrNil]
+ ifFalse: [self errorStackOutOfSync: stackOrNil]
+!
+
+position
+
+ ^position
+!
+
+size
+
+ ^length
+!
+
+start
+
+ ^ start
+! !
+
+!IRStackCount class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRTempAccess.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,37 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRAccess subclass:#IRTempAccess
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRTempAccess methodsFor:'testing'!
+
+isSelf
+ ^self number = 0.
+!
+
+isTemp
+ ^true.
+!
+
+isTempAccess
+ ^true.
+!
+
+isTempRead
+ ^self isTempAccess and: [self isRead].
+!
+
+isTempStore
+ ^self isTempAccess and: [self isStore].
+! !
+
+!IRTempAccess class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRTempRead.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,31 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRTempAccess subclass:#IRTempRead
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRTempRead methodsFor:'interpret'!
+
+executeOn: interpreter
+ interpreter pushTemp: number.
+! !
+
+!IRTempRead methodsFor:'testing'!
+
+isRead
+ ^true
+!
+
+isStore
+ ^false
+! !
+
+!IRTempRead class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRTempStore.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,32 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRTempAccess subclass:#IRTempStore
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+
+!IRTempStore methodsFor:'interpret'!
+
+executeOn: interpreter
+ interpreter storeTemp: number.
+
+! !
+
+!IRTempStore methodsFor:'testing'!
+
+isRead
+ ^false
+!
+
+isStore
+ ^true
+! !
+
+!IRTempStore class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRTransformTest.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,189 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+TestCase subclass:#IRTransformTest
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR-Tests'
+!
+
+
+!IRTransformTest methodsFor:'testing'!
+
+testAdd
+
+ | iRMethod aCompiledMethod |
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: 1;
+ returnTop;
+ ir.
+
+ (iRMethod allSequences last) last delete.
+ (iRMethod allSequences last) last delete.
+
+ (iRMethod allSequences last)
+ add: (IRInstruction pushLiteral: 2).
+
+ (iRMethod allSequences last)
+ add: (IRInstruction returnTop).
+
+ aCompiledMethod := iRMethod compiledMethod.
+ self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2].
+!
+
+testAddBefore
+
+ | iRMethod aCompiledMethod ret |
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: 1;
+ returnTop;
+ ir.
+
+ (iRMethod allSequences last) last delete.
+ (iRMethod allSequences last) last delete.
+
+ ret := (IRInstruction returnTop).
+
+ (iRMethod allSequences last)
+ add: ret.
+
+ (iRMethod allSequences last)
+ add: (IRInstruction pushLiteral: 2) before: ret.
+
+ aCompiledMethod := iRMethod compiledMethod.
+ self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2].
+!
+
+testAddIntructions
+
+ | iRMethod aCompiledMethod |
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: 1;
+ returnTop;
+ ir.
+
+ (iRMethod allSequences last) last delete.
+ (iRMethod allSequences last) last delete.
+
+ (iRMethod allSequences last)
+ addInstructions: {(IRInstruction pushLiteral: 2). (IRInstruction returnTop)}.
+
+ aCompiledMethod := iRMethod compiledMethod.
+ self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2].
+!
+
+testAddIntructionsBefore
+
+ | iRMethod aCompiledMethod push |
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: 1;
+ returnTop;
+ ir.
+
+ push := (iRMethod allSequences last) at: (iRMethod allSequences size - 1) .
+
+ (iRMethod allSequences last)
+ addInstructions: {(IRInstruction pushLiteral: 2). (IRInstruction returnTop)} before: push.
+
+ aCompiledMethod := iRMethod compiledMethod.
+ self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2].
+!
+
+testAddIntructionsBeforeFromLList
+
+ | iRMethod aCompiledMethod push llist col |
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: 1;
+ returnTop;
+ ir.
+
+ push := (iRMethod allSequences last) at: (iRMethod allSequences size - 1) .
+
+ llist := LinkedList new.
+ llist add: (IRInstruction pushLiteral: 2).
+ llist add: (IRInstruction returnTop).
+
+ col := llist asOrderedCollection.
+
+ (iRMethod allSequences last)
+ addInstructions: col before: push.
+
+ aCompiledMethod := iRMethod compiledMethod.
+ self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2].
+!
+
+testDelete
+
+ | iRMethod aCompiledMethod |
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: 1;
+ pushLiteral: 2;
+ returnTop;
+ ir.
+
+ ((iRMethod allSequences last)
+ detect: [:each | each isConstant: [:c | c == 2]]) delete.
+
+
+ aCompiledMethod := iRMethod compiledMethod.
+ self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 1].
+!
+
+testReplace
+ | iRMethod aCompiledMethod |
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: 1;
+ returnTop;
+ ir.
+
+ (iRMethod allSequences last at: 1)
+ replaceWith: (IRInstruction pushLiteral: 2).
+
+ aCompiledMethod := iRMethod compiledMethod.
+ self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2].
+!
+
+testReplaceInstr
+
+ | iRMethod aCompiledMethod |
+
+ iRMethod := IRBuilder new
+ numRargs: 1;
+ addTemps: #(self); "receiver and args declarations"
+ pushLiteral: 1;
+ returnTop;
+ ir.
+
+ (iRMethod allSequences last at: 1)
+ replaceWithInstructions: {(IRInstruction pushLiteral: 2)}.
+
+ aCompiledMethod := iRMethod compiledMethod.
+ self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2].
+! !
+
+!IRTransformTest class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRTranslator.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,340 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+IRInterpreter subclass:#IRTranslator
+ instanceVariableNames:'pending gen currentInstr trailerBytes'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'NewCompiler-IR'
+!
+
+IRTranslator comment:'I interpret IRMethod instructions, sending the appropriate bytecode messages to my BytecodeGenerator (gen). I hold some messages back in pending awaiting certain sequences of them that can be consolidated into single bytecode instructions, otherwise the pending messages are executed in order as if they were executed when they first appeared.'
+!
+
+
+!IRTranslator class methodsFor:'instance creation'!
+
+new
+ ^ self basicNew initialize.
+
+ "Created: / 11-06-2008 / 09:24:01 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRTranslator methodsFor:'initialization'!
+
+initialize
+ "Invoked when a new instance is created."
+
+ "/ please change as required (and remove this comment)
+ pending := OrderedCollection new.
+ gen := IRBytecodeGenerator new.
+ "/ currentInstr := nil.
+ "/ trailerBytes := nil.
+
+ "/ super initialize. -- commented since inherited method does nothing
+
+ "Created: / 11-06-2008 / 13:46:17 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRTranslator methodsFor:'instructions'!
+
+addLiteral: literal
+ gen addLiteral: literal.
+!
+
+blockReturnTop
+
+ self doPending.
+ gen blockReturnTop.
+!
+
+goto: seqNum
+
+ self doPending.
+ gen goto: seqNum.
+!
+
+if: bool goto: seqNum1 otherwise: seqNum2
+
+ self doPending.
+ gen if: bool goto: seqNum1 otherwise: seqNum2.
+!
+
+jumpOverBlock: blockNum to: seqNum
+
+ self doPending.
+ gen jumpOverBlock: seqNum.
+!
+
+label: seqNum
+
+ pending := OrderedCollection new.
+ gen label: seqNum.
+
+ "Modified: / 11-06-2008 / 10:13:28 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+popTop
+
+ "if last was storeTemp, storeInstVar storeIntoLiteralVariable then convert to storePopTemp, storePopInstVar storePopIntoLiteralVariable"
+ #storeTemp: == self pendingSelector ifTrue: [
+ ^ self pendingSelector: #storePopTemp:].
+ #storeInstVar: == self pendingSelector ifTrue: [
+ ^ self pendingSelector: #storePopInstVar:].
+ #storeIntoLiteralVariable: == self pendingSelector ifTrue:[
+ ^self pendingSelector: #storePopIntoLiteralVariable:].
+ "otherwise do normal pop"
+ self doPending.
+ gen popTop.
+!
+
+pushBlock: irMethod
+
+ | meth block |
+ meth _ irMethod compiledMethodWith: trailerBytes.
+ meth isBlockMethod: true.
+ block _ meth createBlock: nil.
+ self addPending: (Message selector: #pushLiteral: argument: block)
+!
+
+pushBlockMethod: irMethod
+
+ | meth |
+ meth _ irMethod compiledMethodWith: trailerBytes.
+ meth isBlockMethod: true.
+ self addPending: (Message selector: #pushLiteral: argument: meth)
+!
+
+pushDup
+
+ self doPending.
+ gen pushDup.
+!
+
+pushInstVar: index
+
+ "self doPending.
+ gen pushInstVar: index."
+ self addPending: (Message selector: #pushInstVar: argument: index)
+!
+
+pushLiteral: object
+
+ self addPending: (Message selector: #pushLiteral: argument: object)
+!
+
+pushLiteralVariable: object
+
+ self addPending: (Message selector: #pushLiteralVariable: argument: object)
+!
+
+pushTemp: index
+
+ index = 0 ifTrue: [^ self addPending: (Message selector: #pushReceiver)].
+
+ (self pendingMatches: {
+ [:m | m selector == #storePopTemp: and: [m argument = index]]}
+ ) ifTrue: [^ self pendingSelector: #storeTemp:].
+
+ self doPending.
+
+ index = -2 ifTrue: [^ gen pushThisContext].
+ index = -1 ifTrue: [
+ ^ gen pushThisContext;
+ pushLiteral: MethodContext myEnvFieldIndex;
+ send: #privGetInstVar:].
+
+ gen pushTemp: index.
+!
+
+remoteReturn
+
+ self doPending.
+ gen remoteReturn.
+!
+
+returnTop
+
+ #pushReceiver == self pendingSelector ifTrue: [
+ self pendingSelector: #returnReceiver.
+ ^ self doPending
+ ].
+ #pushLiteral: == self pendingSelector ifTrue: [
+ self pendingSelector: #returnConstant:.
+ ^ self doPending
+ ].
+ #pushInstVar: == self pendingSelector ifTrue: [
+ self pendingSelector: #returnInstVar:.
+ ^ self doPending
+ ].
+ self doPending.
+ gen returnTop.
+!
+
+send: selector
+
+ "If get/set inst var, access it directly"
+ | index |
+
+ ((#(privGetInstVar: #privStoreIn:instVar:) identityIncludes: selector) and:
+ [self pendingMatches: {
+ [:m | m selector == #pushReceiver].
+ [:m | m selector == #pushLiteral: and: [m argument isInteger]]}]
+ ) ifTrue: [
+ index _ self popPending argument.
+ self popPending. "pop pushReceiver"
+ self addPending: (Message
+ selector: (selector == #privGetInstVar:
+ ifTrue: [#pushInstVar:] ifFalse: [#storeInstVar:])
+ argument: index).
+ (self pendingMatches: {
+ [:m | m selector == #storePopInstVar: and: [m argument = index]].
+ [:m | m selector == #pushInstVar: and: [m argument = index]]}
+ ) ifTrue: [
+ self popPending.
+ self pendingSelector: #storeInstVar:.
+ ].
+ ^ self
+ ].
+ "otherwise do normal send"
+ self doPending.
+ gen send: selector.
+!
+
+send: selector toSuperOf: behavior
+
+ self doPending.
+ gen send: selector toSuperOf: behavior.
+!
+
+storeInstVar: index
+ "self doPending.
+ gen storeInstVar: index"
+ self addPending: (Message selector: #storeInstVar: argument: index)
+!
+
+storeIntoLiteralVariable: assoc
+
+ "self doPending.
+ gen storeIntoLiteralVariable: assoc."
+
+ self addPending: (Message selector: #storeIntoLiteralVariable: argument: assoc)
+!
+
+storeTemp: index
+
+ index = -1 "thisEnv" ifTrue: [
+ self doPending.
+ ^ gen pushThisContext;
+ pushLiteral: MethodContext myEnvFieldIndex;
+ send: #privStoreIn:instVar:].
+
+ self addPending: (Message selector: #storeTemp: argument: index)
+! !
+
+!IRTranslator methodsFor:'interpret'!
+
+interpret: ir
+
+ ir optimize.
+ gen numArgs: ir numArgs.
+ ir additionalLiterals do: [:lit | gen addLiteral: lit].
+ super interpret: ir.
+
+ "Modified: / 11-06-2008 / 13:52:20 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+interpretAll: irSequences
+
+ irSequences withIndexDo: [:seq :i | seq orderNumber: i].
+ super interpretAll: irSequences.
+!
+
+interpretInstruction: irInstruction
+
+ currentInstr := irInstruction.
+ super interpretInstruction: irInstruction.
+
+ "Modified: / 11-06-2008 / 09:20:30 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRTranslator methodsFor:'priv pending'!
+
+addPending: message
+
+ pending addLast: currentInstr -> message
+!
+
+doPending
+ "execute pending instructions"
+
+ | assoc |
+ [pending isEmpty] whileFalse: [
+ assoc _ pending removeFirst.
+ gen mapBytesTo: assoc key "instr".
+ assoc value "message" sendTo: gen.
+ ].
+ gen mapBytesTo: currentInstr.
+!
+
+pendingMatches: blocks
+ "Return true if each message at end of pending list satisfies its corresponding block. The number of elements tested equals the number of blocks. If not enough elements return false"
+
+ | messages i |
+ messages _ pending collect: [:assoc | assoc value].
+ blocks size > messages size ifTrue: [^ false].
+ i _ messages size - blocks size.
+ blocks do: [:b |
+ (b value: (messages at: (i _ i + 1))) ifFalse: [^ false].
+ ].
+ ^ true
+!
+
+pendingSelector
+
+ pending isEmpty ifTrue: [^ nil].
+ ^ pending last value "message" selector
+!
+
+pendingSelector: selector
+
+ pending last value "message" setSelector: selector
+!
+
+popPending
+
+ ^ pending removeLast value "message"
+! !
+
+!IRTranslator methodsFor:'private - literals'!
+
+indexOfLiteral: object
+
+ | idx |
+ idx := literalFrame identityIndexOf: object.
+ idx = 0 ifTrue:
+ [literalFrame add: object.
+ idx := literalFrame identityIndexOf: object].
+ ^idx
+
+ "Created: / 11-06-2008 / 10:56:24 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRTranslator methodsFor:'results'!
+
+compiledMethod
+
+ ^ gen compiledMethodWith: trailerBytes
+!
+
+compiledMethodUsing: aCompiledMethodClass
+
+ ^ gen compiledMethodUsing: aCompiledMethodClass
+
+ "Modified: / 11-06-2008 / 14:08:02 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!IRTranslator class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/extensions.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,20 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+!
+
+!Class methodsFor:'accessing'!
+
+binding
+
+ ^self fullName asSymbol
+
+ "Created: / 11-06-2008 / 11:20:35 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+!Class methodsFor:'accessing'!
+
+bindingOf: classVarName
+
+ ^(self fullName , ':' , classVarName) asSymbol
+
+ "Created: / 11-06-2008 / 11:29:19 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/stx_goodies_newcompiler.st Wed Jun 11 14:54:42 2008 +0000
@@ -0,0 +1,116 @@
+"{ Package: 'stx:goodies/newcompiler' }"
+
+LibraryDefinition subclass:#stx_goodies_newcompiler
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'* Projects & Packages *'
+!
+
+
+!stx_goodies_newcompiler class methodsFor:'description'!
+
+preRequisites
+ ^ #(
+ #'stx:goodies/libtool3' "Tools::Inspector2Tab - referenced by IRMethod>>inspector2TabIRCode "
+ #'stx:goodies/refactoryBrowser/parser' "RBIdentifierToken - referenced by IRDecompiler>>newVar: "
+ #'stx:goodies/sunit' "TestCase - superclass of IRTransformTest "
+ #'stx:libbasic' "Object - superclass of IRTransformTest "
+ #'stx:libcomp' "PrimitiveNode - referenced by IRMethod>>initialize "
+ #'stx:libcompat' "Preferences - referenced by IRDecompiler>>removeClosureCreation: "
+ #'stx:libwidg' "ScrollableView - referenced by IRMethod>>inspector2TabIRCode "
+ )
+
+ "Modified: / 11-06-2008 / 16:54:12 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!stx_goodies_newcompiler class methodsFor:'description - contents'!
+
+classNamesAndAttributes
+ ^ #(
+ "<className> or (<className> attributes...) in load order"
+ IRBuilder
+ IRBuilderTest
+ IRBytecodeGenerator
+ IRInstruction
+ IRInterpreter
+ IRMethod
+ IRSequence
+ IRStackCount
+ IRTransformTest
+ #'stx_goodies_newcompiler'
+ IRAccess
+ IRConstant
+ IRDecompiler
+ IRDup
+ IRJump
+ IRPop
+ IRPrinter
+ IRReturn
+ IRSend
+ IRTranslator
+ IRBlockReturnTop
+ IRInstVarAccess
+ IRJumpIf
+ IRJumpOverBlock
+ IRLiteralVariableAccess
+ IRTempAccess
+ IRInstVarRead
+ IRInstVarStore
+ IRLiteralVariableRead
+ IRLiteralVariableStore
+ IRTempRead
+ IRTempStore
+ )
+
+ "Modified: / 11-06-2008 / 16:54:11 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+extensionMethodNames
+ ^ #(
+ Class binding
+ Class bindingOf:
+ )
+
+ "Modified: / 11-06-2008 / 16:54:12 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!stx_goodies_newcompiler class methodsFor:'description - project information'!
+
+companyName
+ "Return a companyname which will appear in <lib>.rc"
+
+ ^ 'CVUT FEI & Mathieu Suen'
+
+ "Created: / 11-06-2008 / 16:50:46 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+description
+ "Return a description string which will appear in vc.def / bc.def"
+
+ ^ 'Smalltalk/X Bytecode generation library based on Squeak''s NewCompiler'
+
+ "Created: / 11-06-2008 / 16:50:46 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+legalCopyright
+ "Return a copyright string which will appear in <lib>.rc"
+
+ ^ 'Copyright Jan Vrany & Mathieu Suen 2008'
+
+ "Created: / 11-06-2008 / 16:50:46 / Jan Vrany <vranyj1@fel.cvut.cz>"
+!
+
+productName
+ "Return a product name which will appear in <lib>.rc"
+
+ ^ 'NewCompiler'
+
+ "Created: / 11-06-2008 / 16:50:46 / Jan Vrany <vranyj1@fel.cvut.cz>"
+! !
+
+!stx_goodies_newcompiler class methodsFor:'documentation'!
+
+version
+ ^'$Id$'
+! !