Tests moved to separate subpackage to follow St/X conventions.
"{ Package: 'ctu:ircompiler' }"
Object subclass:#IRFunction
instanceVariableNames:'startSequence primitiveNode tempKeys tempMap numRargs properties
additionalLiterals maxOrderNumber sourceMap environmentIr
compiledCode'
classVariableNames:''
poolDictionaries:''
category:'IR Compiler-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_CVS
^ 'Header: /cvs/stx/cvut/stx/goodies/newcompiler/IRFunction.st,v 1.4 2009/10/08 11:59:08 fm Exp '
!
version_SVN
^ '$Id:: $'
! !