"{ 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)

    "Modified: / 03-11-2008 / 11:52:48 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

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"

        | jumpInstrs |

        self startNewSequence.

        jumpInstrs := (jumpAheadStacks at: labelSymbol ifAbsent: [

                        self error: 'Missing jumpAheadTo: ', labelSymbol printString]).

        jumpInstrs do:[:jumpInstr | jumpInstr destination: currentSequence].

        jumpInstrs removeLast.

    "Modified: / 03-11-2008 / 12:00:44 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

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.

!

line: line

        self add: (IRInstruction line: line)

    "Created: / 02-12-2008 / 09:00:15 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

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 numArgs: numArgs

        self add: (IRInstruction send: selector numArgs: numArgs)

    "Created: / 01-12-2008 / 19:56:10 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

send: selector numArgs: numArgs toSuperOf: behavior

        self add: (IRInstruction send: selector numArgs: numArgs toSuperOf: behavior)

    "Created: / 01-12-2008 / 19:56:20 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

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$'

! !