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

Object subclass:#IRFunction

	instanceVariableNames:'startSequence primitiveNode tempKeys tempMap numRargs properties

		additionalLiterals maxOrderNumber sourceMap environmentIr

		compiledCode'

	classVariableNames:''

	poolDictionaries:''

	category:'NewCompiler-IR'

!

!IRFunction methodsFor:'accessing'!

addLiteral: aSymbol

	additionalLiterals add: aSymbol.

!

addLiterals: anArray

	additionalLiterals addAll: anArray.

!

addTemps: newKeys

    | keys i new |

    keys := self tempKeys.

    new := OrderedCollection new.

    newKeys do: 

        [:key |

        tempMap at: key ifAbsentPut: 

            [new add: key.

            i := i + 1]].

    self tempKeys: keys, new.

!

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

!

numRargs

	^ numRargs

!

primitiveNode

	^ primitiveNode

!

properties

	^properties

!

properties: propDict

	properties := propDict.

!

startSequence

	^ startSequence

!

tempKeys

	^ tempKeys

!

tempMap

    ^ tempMap

!

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

! !

!IRFunction methodsFor:'accessing - defaults'!

defaultCompiledCodeClass

    "raise an error: must be redefined in concrete subclass(es)"

    ^ self subclassResponsibility

! !

!IRFunction 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>"

! !

!IRFunction methodsFor:'decompiling'!

ast

	^ IRDecompiler new decompileIR: self

! !

!IRFunction methodsFor:'initialize'!

initialize

        primitiveNode := PrimitiveNode primitiveNumber: 0.

        tempKeys := OrderedCollection new.

        tempMap := Dictionary new.

        properties := Dictionary new. 

        additionalLiterals := OrderedCollection new.

    "Modified: / 30-03-2009 / 11:16:15 / 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

! !

!IRFunction 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.

! !

!IRFunction methodsFor:'instructions - helpers'!

pushTemp: tempName in: irFunction level: level

    | index kind |

    index := tempMap 

                at: tempName 

                ifAbsent:

                    [environmentIr

                        ifNil:[self error:'No such temp: ', tempName]

                        ifNotNil:[^environmentIr pushTemp: tempName in: irFunction level: level + 1]].

    kind := (index <= self numArgs)

                ifTrue: [self tempArgKindForLevel: level]

                ifFalse:[index := index - self numArgs.self tempVarKindForLevel: level].

    ^IRInstruction pushTemp: index kind: kind level: level

    "Created: / 30-03-2009 / 11:54:14 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 30-03-2009 / 13:59:14 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

storeTemp: tempName in: irFunction level: level

    | index kind |

    index := tempMap 

                at: tempName 

                ifAbsent:

                    [environmentIr

                        ifNil:[self error:'No such temp: ', tempName]

                        ifNotNil:[^environmentIr storeTemp: tempName in: irFunction level: level + 1]].

    kind := (index <= self numArgs)

                ifTrue: [self tempArgKindForLevel: level]

                ifFalse:[index := index - self numArgs.self tempVarKindForLevel: level].

    ^IRInstruction storeTemp: index kind: kind level: level

    "Created: / 30-03-2009 / 11:57:05 / Jan Vrany <vranyj1@fel.cvut.cz>"

    "Modified: / 30-03-2009 / 13:59:25 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

tempArgKindForLevel: level

    ^self subclassResponsibility

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

!

tempVarKindForLevel: level

    ^self subclassResponsibility

    "Created: / 30-03-2009 / 11:58:25 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRFunction 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 compiledCode 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

! !

!IRFunction 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].

! !

!IRFunction 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>"

! !

!IRFunction methodsFor:'testing'!

isIRClosure

    ^ false

!

isIRMethod

    ^ false

!

isSend

	^false.

! !

!IRFunction methodsFor:'translating'!

bytecodes

        ^ compiledCode 

            ifNotNil: 

                [compiledCode byteCode]                

            ifNil:

                [IRTranslator new

                    interpret: self;

                    bytecodes]

    "Created: / 03-11-2008 / 08:38:02 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

compiledCode

    ^ compiledCode 

        ifNil:[ self compiledCodeUsing:self defaultCompiledCodeClass ]

    "Created: / 30-03-2009 / 16:34:33 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

compiledCodeUsing:aCompiledCodeClass 

    ^ compiledCode := (IRTranslator new)

                interpret:self;

                compiledCodeUsing:aCompiledCodeClass

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

!

literals

        ^(IRTranslator new

            interpret: self;

            literals)

    "Created: / 03-11-2008 / 09:08:23 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

setCompiledCode:aCompiledCode 

    compiledCode := aCompiledCode

    "Created: / 11-06-2008 / 11:05:57 / Jan Vrany <vranyj1@fel.cvut.cz>"

! !

!IRFunction class methodsFor:'documentation'!

version

    ^'$Id$'

! !