"{ Package: 'cvut:stx/goodies/newcompiler' }"

Object subclass:#IRBuilder

	instanceVariableNames:'ir jumpBackTargetStacks jumpAheadStacks currentSequence

		sourceMapNodes sourceMapByteIndex lastLine'

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

for: anIRFunction

    ^ self basicNew initializeFor: anIRFunction.

    "Created: / 30-03-2009 / 18:28:01 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

forClosure

    ^ self basicNew initializeFor: IRClosure new.

    "Created: / 30-03-2009 / 18:28:22 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

forMethod

    ^ self basicNew initializeFor: IRMethod new.

    "Created: / 30-03-2009 / 18:28:10 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

new

    ^ self forMethod

    "Created: / 11-06-2008 / 00:51:36 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 30-03-2009 / 18:28:32 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

numRargs: numRargs tempNames: tempNames

    ^ self forMethod

        numRargs: numRargs;

        addTemps: tempNames;

        yourself

    "Created: / 17-08-2009 / 14:19:15 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRBuilder methodsFor:'accessing'!

closureBuilder

    ^IRBuilder forClosure

        environmentIr: ir;

        yourself

    "Created: / 30-03-2009 / 18:29:15 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

currentSequence

	^currentSequence

!

environmentIr: anIRFunction

    ir environmentIr: anIRFunction

    "Created: / 30-03-2009 / 18:30:22 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

properties: aDict

	ir properties: aDict

! !

!IRBuilder methodsFor:'decompiling'!

addJumpBackTarget: label to: sequence

	(jumpBackTargetStacks at: label ifAbsentPut: [OrderedCollection new])

		addLast: sequence

!

addTemps: newKeys

    ir addTemps: newKeys

    "Modified: / 30-03-2009 / 11:15:46 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

tempNames

    ^ir tempNames

    "Modified: / 30-03-2009 / 11:15:46 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

testJumpAheadTarget: label

	jumpAheadStacks at: label ifPresent: [:stack |

		[stack isEmpty] whileFalse: [self jumpAheadTarget: label]

	]

! !

!IRBuilder methodsFor:'initialize'!

addTemp: tempKey

	self addTemps: {tempKey}

!

addTempIfNotDefined: tempKey

        self addTempsIfNotDefined: (Array with: tempKey)

    "Created: / 23-03-2010 / 13:46:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

addTempsIfNotDefined: temps

    ir addTempsIfNotDefined: temps

    "Created: / 23-03-2010 / 13:46:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

initialize

    ^self initializeFor: IRMethod new.

    "Modified: / 30-03-2009 / 18:27:31 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

initializeFor: anIRFunction

        ir := anIRFunction.

        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)

    "Created: / 30-03-2009 / 18:27:04 / 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 

    lastLine ~= line ifTrue:

        [self add:(IRInstruction line:line).

        lastLine := line].

    "Modified: / 12-05-2009 / 16:11:01 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

popTop

	self add: IRInstruction popTop

!

pushBlock: irClosure

    self 

        assert: irClosure isIRClosure

        message: 'Argument must be an instance of irClosure'.

    self add: (IRInstruction pushBlock: irClosure)

    "Modified: / 30-03-2009 / 16:49:07 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

pushBlockUsingBuilder: oneArgBlock

    | closureBuilder  |

    closureBuilder := self closureBuilder.

    oneArgBlock value: closureBuilder.

    ^self pushBlock: closureBuilder ir

    "Created: / 30-03-2009 / 18:32:02 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

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 

    self add: (ir pushTemp: key in: ir level: 0)

    "Modified: / 30-03-2009 / 12:00:08 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

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 

    self add: (ir storeTemp: key in: ir level: 0)

    "Modified: / 30-03-2009 / 12:00:28 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

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

    "Modified: / 28-03-2009 / 21:01:46 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRBuilder class methodsFor:'documentation'!

version

    ^ '$Header: /cvs/stx/cvut/stx/goodies/newcompiler/IRBuilder.st,v 1.3 2009/10/08 11:57:58 fm Exp $'

!

version_CVS

    ^ '$Header: /cvs/stx/cvut/stx/goodies/newcompiler/IRBuilder.st,v 1.3 2009/10/08 11:57:58 fm Exp $'

!

version_SVN

    ^ '$Id$'

! !