--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/IRFunction.st Mon Mar 30 14:47:18 2009 +0000
@@ -0,0 +1,444 @@
+"{ 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.
+ 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]].
+ self tempKeys: keys, new.
+
+ "Modified: / 30-03-2009 / 11:15:22 / 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 - 1
+!
+
+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$'
+! !