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

Object subclass:#IRFunction

	instanceVariableNames:'startSequence primitiveNode tempKeys tempMap numRargs properties

		additionalLiterals maxOrderNumber sourceMap environmentIr

		compiledCode'

	classVariableNames:''

	poolDictionaries:''

	category:'NewCompiler-IR'

!

!IRFunction class methodsFor:'instance creation'!

new

    ^ self basicNew initialize.

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

! !

!IRFunction methodsFor:'accessing'!

addLiteral: aSymbol

	additionalLiterals add: aSymbol.

!

addLiterals: anArray

	additionalLiterals addAll: anArray.

!

addTemps: newKeys

    | keys i new |

    keys := self tempKeys.

    i := keys size -

	    (self isIRMethod

		ifTrue:[1 "zero-based (index 0 equals receiver - self)"]

		ifFalse:[0]).

    new := OrderedCollection new.

    newKeys do:

	[:key |

	tempMap at: key ifAbsentPut:

	    [new add: key.

	    i := i + 1]].

    new isEmpty ifTrue:[^self].

    self tempKeys: keys, new.

    "Modified: / 12-08-2009 / 09:22:05 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

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

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

!

numRargs

	^ numRargs

!

numVars

	^ self tempKeys size - self numRargs

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

!

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

	|translator|

	^ compiledCode isNil

	    ifTrue:[

		translator := IRTranslator new.

		translator interpret: self.

		translator bytecodes

	    ]

	    ifFalse: [compiledCode byteCode].

    "Rewrited due to compilation error: Fatal: [bytecodes 10] block not prescanned inline "

"/        ^ 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$'

!

version_CVS

    ^ '§Header: /cvs/stx/cvut/stx/goodies/newcompiler/IRFunction.st,v 1.4 2009/10/08 11:59:08 fm Exp §'

!

version_SVN

    ^ '$Id::                                                                                                                        $'

! !