'From Squeak3.2gamma of May 26, 2002 on 26 May 2002 at 11:14:14 AM'!
Object subclass: #NativeCode
  instanceVariableNames: 'instructions labels constants relocations '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Code'!

!NativeCode class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!NativeCode methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  instructions _ ByteArray new.
  labels _ IntegerArray new.
  constants _ Array new.
  relocations _ Array new! !

!NativeCode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
instructions
  ^ instructions! !

!NativeCode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
labels
  ^ labels! !

!NativeCode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
constants
  ^ constants! !

!NativeCode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
relocations
  ^ relocations! !

!NativeCode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
instructions: aByteArray
  instructions _ aByteArray! !

!NativeCode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
labels: anIntegerArray
  labels _ anIntegerArray! !

!NativeCode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
constants: anArray
  constants _ anArray! !

!NativeCode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
relocations: anArray
  relocations _ anArray! !

!NativeCode methodsFor: 'relocating' stamp: 'lrs 05/26/2002 11:14'!
relocate
  relocations 
    do: [:relocation |
          relocation relocate: self]! !

Object subclass: #Translator
  instanceVariableNames: 'compilationUnit function basicBlock '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Representation'!

!Translator class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
on: aCompilationUnit
  ^ super new on: aCompilationUnit! !

!Translator methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
on: aCompilationUnit
  compilationUnit _ aCompilationUnit! !

!Translator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
compilationUnit
  ^ compilationUnit! !

!Translator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function
  ^ function! !

!Translator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock
  ^ basicBlock! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translate
  compilationUnit functions copy
    do:
      [:currentFunction |
        function _ currentFunction.
        self beginTranslatingFunction: currentFunction.
        currentFunction basicBlocks copy
          do:
            [:currentBasicBlock |
              basicBlock _ currentBasicBlock.
              self beginTranslatingBasicBlock: currentBasicBlock.
              currentBasicBlock
                do:
                 [:currentInstruction |
                   currentInstruction translateOn: self].
              self endTranslatingBasicBlock: currentBasicBlock].
        self endTranslatingfunction: currentFunction]! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
beginTranslatingFunction: aFunction
  self subclassResponsibility! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
endTranslatingFunction: aFunction
  self subclassResponsibility! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
beginTranslatingBasicBlock: aBasicBlock
  self subclassResponsibility! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
endTranslatingBasicBlock: aBasicBlock
  self subclassResponsibility! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateInstruction: anInstruction
  self subclassResponsibility! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateProjection: aProjectionInstruction
  self translateInstruction: aProjectionInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateMerge: aMergeInstruction
  self translateInstruction: aMergeInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateNot: aNotInstruction
  self translateInstruction: aNotInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOr: anOrInstruction
  self translateInstruction: anOrInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateXor: anXorInstruction
  self translateInstruction: anXorInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateAnd: anAndInstruction
  self translateInstruction: anAndInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateLogicalShiftRight: aLogicalShiftRightInstruction
  self translateInstruction: aLogicalShiftRightInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateLogicalShiftLeft: aLogicalShiftLeftInstruction
  self translateInstruction: aLocalShiftleftInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateArithmeticShiftRight: anArithmeticShiftRightInstruction
  self translateInstruction: anArithmeticShiftRightInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateAdd: anAddInstruction
  self translateInstruction: anAddInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateSubtract: aSubtractInstruction
  self translateInstruction: aSubtractInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateMultiply: aMultiplyInstruction
  self translateInstruction: aMultiplyInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateDivide: aDivideInstruction
  self translateInstruction: aDivideInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateRemainder: aRemainderInstruction
  self translateInstruction: aRemainderInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateMove: aMoveInstruction
  self translateInstruction: aMoveInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateTruncate: aTruncateInstruction
  self translateInstruction: aTruncateInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateSignExtend: aSignExtendInstruction
  self translateInstruction: aSignExtendInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateZeroExtend: aZeroExtendInstruction
  self translateInstruction: aZeroExtendInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateConvert: aConvertInstruction
  self translateInstruction: aConvertInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateLoad: aLoadInstruction
  self translateInstruction: aLoadInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateStore: aStoreInstruction
  self translateInstruction: aStoreInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translatePush: aPushInstruction
  self translateInstruction: aPushInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translatePop: aPopInstruction
  self translateInstruction: aPopInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateAllocate: anAllocateInstruction
  self translateInstruction: anAllocateInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateFree: aFreeInstruction
  self translateInstruction: aFreeInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translatePrologue: aPrologueInstruction
  self translateInstruction: aPrologueInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateEpilogue: anEpilogueInstruction
  self translateInstruction: aEpilogueInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateSpill: aSpillInstruction
  self translateInstruction: aSpillInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateReload: aReloadInstruction
  self translateInstruction: aReloadInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateClobber: aClobberInstruction
  self translateInstruction: aClobberInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateJump: aJumpInstruction
  self translateInstruction: aJumpInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateBranchEqual: aBranchEqualInstruction
  self translateInstruction: aBranchEqualInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateBranchNotEqual: aBranchNotEqualInstruction
  self translateInstruction: aBranchNotEqualInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateBranchLess: aBranchLessInstruction
  self translateInstruction: aBranchLessInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateBranchLessEqual: aBranchLessEqualInstruction
  self translateInstruction: aBranchlessEqualInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateBranchGreater: aBranchGreaterInstruction
  self translateInstruction: aBranchGreaterInstruction! !

!Translator methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateBranchGreaterEqual: aBranchGreaterEqualInstruction
  self translateInstruction: aBranchGreaterEqualInstruction! !

Object subclass: #Assembler
  instanceVariableNames: 'instructions labels constants relocations '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Code'!

!Assembler class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!Assembler methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  instructions _ ReadWriteStream on: (ByteArray new: 512).
  labels _ ReadWriteStream on: (IntegerArray new: 16).
  constants _ ReadWriteStream on: (Array new: 16).
  relocations _ ReadWriteStream on: (Array new: 16)! !

!Assembler methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
instructions
  ^ instructions! !

!Assembler methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
labels
  ^ labels! !

!Assembler methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
constants
  ^ constants! !

!Assembler methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
relocations
  ^ relocations! !

!Assembler methodsFor: 'assembling' stamp: 'lrs 05/26/2002 11:14'!
defineLabel
  labels nextPut: instructions position.
  ^ labels position - 1! !

!Assembler methodsFor: 'assembling' stamp: 'lrs 05/26/2002 11:14'!
defineConstant: anObject
  constants nextPut: anObject.
  ^ constants position - 1! !

!Assembler methodsFor: 'assembling' stamp: 'lrs 05/26/2002 11:14'!
addRelocation: aRelocation
  aRelocation offset: instructions position.
  relocations nextPut: aRelocation! !

Object subclass: #Relocation
  instanceVariableNames: 'offset '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Code'!

!Relocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
offset
  ^ offset! !

!Relocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
offset: anInteger
  offset _ anInteger! !

!Relocation methodsFor: 'relocating' stamp: 'lrs 05/26/2002 11:14'!
relocate: aNativeCode
  self subclassResponsibility! !

!Relocation methodsFor: 'relocating' stamp: 'lrs 05/26/2002 11:14'!
relocate: aNativeCode with: anObject
  self subclassResponsibility! !

Relocation subclass: #ConstantRelocation
  instanceVariableNames: 'constant '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Code'!

!ConstantRelocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
constant
  ^ constant! !

!ConstantRelocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
constant: anInteger
  constant _ anInteger! !

!ConstantRelocation methodsFor: 'relocating' stamp: 'lrs 05/26/2002 11:14'!
relocate: aNativeCode
  self relocate: aNativeCode with: (aNativeCode constants at: constant)! !

Relocation subclass: #LabelRelocation
  instanceVariableNames: 'label '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Code'!

!LabelRelocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
label
  ^ label! !

!LabelRelocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
label: anInteger
  label _ anInteger! !

!LabelRelocation methodsFor: 'relocating' stamp: 'lrs 05/26/2002 11:14'!
relocate: aNativeCode
  self relocate: aNativeCode with: (aNativeCode labels at: label)! !

Relocation subclass: #RelativeLabelRelocation
  instanceVariableNames: 'label '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Code'!

!RelativeLabelRelocation methodsFor: 'relocating' stamp: 'lrs 05/26/2002 11:14'!
relocate: aNativeCode
  self relocate: aNativeCode with: (aNativeCode labels at: label) - self offset - 1! !

Object subclass: #CompilationUnit
  instanceVariableNames: 'architecture globalVariables functions '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Representation'!

!CompilationUnit class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!CompilationUnit methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  globalVariables _ OrderedCollection new.
  functions _ OrderedCollection new! !

!CompilationUnit methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
architecture
  ^ architecture! !

!CompilationUnit methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
architecture: anArchitecture
  architecture _ anArchitecture! !

!CompilationUnit methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
globalVariables
  ^ globalVariables! !

!CompilationUnit methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
functions
  ^ functions! !

Object subclass: #Architecture
  instanceVariableNames: 'conditionType integerType floatType pointerType registerSet calleeSaveRegisters callerSaveRegisters inputVariables outputVariables'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Representation'!

!Architecture class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!Architecture methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  registerSet _ Set new.
  calleeSaveRegisters _ Set new.
  callerSaveRegisters _ Set new.
  inputVariables _ OrderedCollection new.
  outputVariables _ OrderedCollection new! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
registerSet
  ^ registerSet! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
calleeSaveRegisters
  ^ calleeSaveRegisters! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
callerSaveRegisters
  ^ callerSaveRegisters! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
inputVariables
  ^ inputVariables! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
outputVariables
  ^ outputVariables! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
conditionType
  ^ conditionType! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
conditionType: aConditionStorageType
  conditionType _ aConditionStorageType! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
integerType
  ^ integerType! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
integerType: anIntegerStorageType
  integerType _ anIntegerStorageType! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
floatType
  ^ floatType! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
floatType: aFloatStorageType
  floatType _ aFloatStorageType! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
pointerType
  ^ pointerType! !

!Architecture methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
pointerType: aPointerStorageType
  pointerType _ aPointerStorageType! !

ListElement subclass: #Bracket
  instanceVariableNames: 'source destination equivalenceClass recentSize recentClass '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Analyses'!

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
source
  ^ source! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
source: aCycleEquivalenceNode
  source _ aCycleEquivalenceNode! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
destination
  ^ destination! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
destination: aCycleEquivalenceNode
  destination _ aCycleEquivalenceNode! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
equivalenceClass
  ^ equivalenceClass! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
equivalenceClass: anInteger
  equivalenceClass _ anInteger! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
recentSize
  ^ recentSize! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
recentSize: anInteger
  recentSize _ anInteger! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
recentClass
  ^ recentClass! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
recentClass: anInteger
  recentClass _ anInteger! !

!Bracket methodsFor: 'testing' stamp: 'lrs 05/26/2002 11:14'!
includes: aCycleEquivalenceNode
  ^ source == aCycleEquivalenceNode
      or: [destination == aCycleEquivalenceNode]! !

!Bracket methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
opposite: aCycleEquivalenceNode
  ^ source == aCycleEquivalenceNode
      ifTrue: [destination]
      ifFalse: [source]! !

Object subclass: #CycleEquivalenceNode
  instanceVariableNames: 'basicBlock parent children crossEdges cappingEdges depthFirstNumber highest brackets '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Analyses'!

!CycleEquivalenceNode class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!CycleEquivalenceNode methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  children _ Set new.
  crossEdges _ Set new.
  cappingEdges _ Set new.
  brackets _ List new! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock
  ^ basicBlock! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock: aRegion
  basicBlock _ aRegion! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
parent
  ^ parent! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
parent: aCycleEquivalenceNode
  parent _ aCycleEquivalenceNode! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
depthFirstNumber
  ^ depthFirstNumber! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
depthFirstNumber: anInteger
  depthFirstNumber _ anInteger! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
children
  ^ children! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
crossEdges
  ^ crossEdges! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
cappingEdges
  ^ cappingEdges! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
brackets
  ^ brackets! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
highest
  ^ highest! !

!CycleEquivalenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
highest: anInteger
  highest _ anInteger! !

Object subclass: #ControlDependenceAnalyzer
  instanceVariableNames: 'function representativeEdges depthFirstOrder equivalenceClasses controlDependence equivalentRegions '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Analyses'!

!ControlDependenceAnalyzer class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!ControlDependenceAnalyzer methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  equivalenceClasses _ 0! !

!ControlDependenceAnalyzer methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function
  ^ function! !

!ControlDependenceAnalyzer methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function: aFunction
  function _ aFunction! !

!ControlDependenceAnalyzer methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
newEquivalenceClass
  equivalenceclasses _ equivalenceClasses + 1.
  ^ equivalenceClasses! !

!ControlDependenceAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
buildNodes
  | entryNodes exitNodes entryNode exitNode bracket root |
  entryNodes _ Dictionary new.
  exitNodes _ Dictionary new.
  representativeEdges _ Dictionary new.
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        entryNode _ CycleEquivalenceNode new basicBlock: basicBlock.
        exitNode _ CycleEquivalenceNode new basicBlock: basicBlock.
        bracket _ Bracket new source: entryNode destination: exitNode.
        representativeEdges at: basicBlock put: bracket.
        entryNode children add: bracket.
        exitNode children add: bracket].
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          doPredecessors:
            [:predecessor |
              entryNode _ entryNodes at: basicBlock.
              exitNode _ exitNodes at: predecessor.
              bracket _ Bracket new source: exitNode destination: entryNode.
              entryNode children add: bracket.
              exitNode children add: bracket]].
  root _ entryNodes at: function entry.
  exitNodes
    do:
      [:node |
        node children size <= 1
          ifTrue:
            [bracket _ Bracket new 
                         source: node 
                         destination: root.
              root children add: bracket.
              node children add: bracket]]! !

!ControlDependenceAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeDepthFirstOrder
  | newNode workList |
  depthFirstOrder _ OrderedCollection new: 2 * representativeEdges size.
  workList _ OrderedCollection 
               with: 
                 (representativeEdges at: function entry) source.
  [workList notEmpty]
    whileTrue:
      [newNode _ workList removeLast.
        newNode depthFirstNumber: depthFirstOrder size + 1.
        depthFirstOrder addLast: newNode.
        newNode children
          do:
            [:edge |
              child _ edge opposite: newNode.
              child parent
                ifNotNil:
                  [node crossEdges add: edge.
                    child children remove: edge ifAbsent: [].
                    child crossEdges add: edge]
                ifNil:
                  [workList
                    addLast:
                      ((child opposite newNode) parent: edge)].
               newNode children removeAllFoundIn: node crossEdges]]! !

!ControlDependenceAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeCycleEquivalence
  | child highBackEdge highChild |
  depthFirstOrder
    reverseDo:
      [:node |
        highBackEdge _ node crossEdges
                         detectMin:
                           [:edge |
                             child _ edge opposite: child.
                             node depthFirstNumber > child depthFirstNumber
                               ifTrue:
                                 [child depthFirstNumber]
                               ifFalse:
                                 [SmallInteger maxVal]].
        highBackEdge _ highBackEdge opposite: node.
        highChild _ node children 
                      detectMin: 
                        [:edge | (edge opposite: node) highest].
        hichChild _ highChild opposite: node.
        node 
          highest: 
            (highBackEdge depthFirstNumber min: highChild depthFirstNumber).
        highChild _ node children detect: [:edge | (edge opposite: node) highest == highChild].
        highChild _ highChild opposite: node.
        highChild _ node
                      detectMin:
                        [:edge |
                          child _ edge opposite: node.
                          child == highChild
                            ifTrue:
                              [SmallInteger maxVal]
                            ifFalse:
                              [child highest]].
        hichChild _ highChild opposite: node.
        node children
          do:
            [:edge |
              node brackets concatenateFirst: (edge opposite: node) brackets].
        node brackets removeAll: node cappingEdges.
        node crossEdges
          do:
            [:edge |
              child _ edge opposite: node.
              node depthFirstNumber >= child depthFirstNumber
                ifTrue:
                  [node brackets 
                    addLast: 
                      (Bracket new source: node destination: child)]
                ifFalse:
                  [node brackets remove: edge.
                    edge equivalenceClass: self newEquivalenceClass]].
        highChild depthFirstNumber < highBackEdge depthFirstNumber
          ifTrue:
            [node brackets 
              addLast: 
                (node crossEdges
                  add:
                    (highChild cappingEdges
                      add:
                        (Bracket new source: node destination: highChild)))].
        node parent
          ifNotNil:
            [child _ node brackets last.
              child recentSize = node brackets size
              ifFalse:
                [child recentSize: node brackets size.
                  child recentClass: self newEquivalenceClass].
              node parent equivalenceClass: child recentClass.
              child resizeSize = 1
                ifTrue:
                  [child equivalenceClass: node parent equivalenceClass]]]! !

!ControlDependenceAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeControlDependence
  | visited representativeEdge currentBasicBlocks parents workList |
  children _ Dictionary new.
  workList _ OrderedCollection with: function entry.
  depthFirstOrder _ OrderedCollection new.
  visited_ Set new.
  [workList notEmpty]
    whileTrue:
      [currentBasicBlock _ workList removeLast.
        currentBasicBlock
          doSuccessors:
            [:successor |
              (visited includes: successor)
                ifFalse:
                  [visited add: successor.
                    workList addLast: successor.
                    depthFirstOrder addLast: successor]]].
  controlDependence _ IntegerArray new: equivalenceClasses.
  equivalentRegions _ Array new: equivalenceClasses.
  parents _ OrderedCollection new.
  currentBasicBlock _ nil.
  depthFirstOrder
    do:
      [:basicBlock |
        representativeEdge _ representativeEdges at: basicBlock.
        (currentBasicBlock isNil
          or:
            [(representativeEdges at: currentBasicBlock) equivalenceClass ~=
              representativeEdge equivalenceClass])
          ifTrue:
            [(equivalentRegions at: representativeEdge equivalenceClass)
              ifNotNil:
                [parents notEmpty
                  ifTrue:
                    [currentBasicBlock _ parents removeLast]
                  ifFalse:
                    [currentBasicBlock _ nil]]
              ifFalse:
                [equivalentRegions 
                  at: representativeEdge equivalenceClass
                  put: OrderedCollection new.
                  currentBasicBlock
                    ifNotNil:
                      [parents notEmpty
                        ifTrue:
                          [controlDependence
                            at: representativeEdge equivalenceClass
                            put:
                              (representativeEdges at: parents last) 
                                equivalenceClass].
                        parents addLast: currentBasicBlock]]].
          (equivalentRegions at: representativeEdge equivalenceClass)
            addLast: basicBlock]! !

!ControlDependenceAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeDepths
  | workList region |
  function entry region depth: 1.
  workList _ OrderedCollection with: function entry region.
  [workList notEmpty]
    whileTrue:
      [region _ workList removeLast.
        region children
          do:
            [:instruction |
              instruction basicBlock region depth
                ifNil:
                  [instruction basicBlock region depth: region depth + 1.
                    workList addLast: instruction basicBlock region]]]! !

!ControlDependenceAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
buildControlDependenceRegions
  | region |
  self buildNodes.
  self computeDepthFirstOrder.
  self computeCycleEquivalence.
  self computeControlDependence.
  equivalentRegions
    do:
      [:basicBlocks |
        region _ Region new function: function.
        basicBlocks
          do:
            [:basicBlock |
              region addLast: basicBlock]].
  self computeDepths!  !

Object subclass: #Function
  instanceVariableNames: 'compilationUnit entry exit localVariables inputVariables outputVariables globalVariables memoryLocations loopNest allocatedRegisters'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Representation'!

!Function class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!Function methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  localVariables _ OrderedCollection new.
  inputVariables _ OrderedCollection new.
  outputVariables _ OrderedCollection new.
  globalVariables _ Set new.
  memoryLocations _ Set new.
  loopNest _ OrderedCollection new! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
compilationUnit
  ^ compilationUnit! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
compilationUnit: aCompilationUnit
  compilationUnit _ aCompilationUnit! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
entry
  ^ entry! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
entry: aBasicBlock
  entry _ aBasicBlock ! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
exit
  ^ exit! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
exit: aBasicBlock
  exit _ aBasicBlock ! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
localVariables
  ^ localVariables! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
inputVariables
  ^ inputVariables! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
outputVariables
  ^ outputVariables! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
memoryLocations
  ^ memoryLocations! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
loopNest
  ^ loopNest! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
allocatedRegisters
  ^ allocatedRegisters! !

!Function methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
allocatedRegisters: aSet
  allocatedRegisters _ aSet! !

!Function methodsFor: 'accounting' stamp: 'lrs 05/26/2002 11:14'!
allocateLocalVariable: aStorageType
  ^ localVariables add: (LocalVariable new storageType: aStorageType)! !

!Function methodsFor: 'accounting' stamp: 'lrs 05/26/2002 11:14'!
allocateMemoryLocation: aStorageType
  ^ memoryLocations add: (MemoryLocation new storageType: aStorageType)! !

!Function methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
eliminatePartialRedundancies
  (PartialRedundancyEliminator new function: self)
    eliminatePartialRedundancies! !

!Function methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpressions
  | substitutions newValue | 
  substitutions _ Dictionary new: 64.
  entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          do:
            [:instruction |
              instruction
                doInputOperandsWithIndex:
                  [:operand :index |
                    substitutions
                      at: operand
                      ifPresent:
                        [:substitute |
                          instruction
                            atInputOperand: index
                            put: newValue]].
              instruction maySimplify
                ifTrue:
                  [newValue _ instruction simplifyExpression.
                    instruction == newValue
                      ifFalse:
                        [substitutions at: instruction put: newValue]]]]! !

!Function methodsFor: 'bounds check hoisting' stamp: 'lrs 05/26/2002 11:14'!
hoistBoundsChecks
  | inductionVariables reusing |
  reusing _ ExpressionDictionary new.
  entry 
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock instructions copy
          do:
            [:instruction |
              instruction sequence = #derived & mayHoist
                ifTrue:
                  [inductionVariables _ instruction derivedFrom: Set new.
                    (inductionVariables
                      allSatisfy:
                        [:inductionVariable |
                          (inductionVariable loop 
                            canPredictInductionVariable: inductionVariable)
                            and:
                              [instruction 
                                postDominates: 
                                  inductionVariable loop entrance basicBlock]])
                      ifTrue:
                        [instruction 
                          insertDerivationBefore: instruction
                          reusing: reusing.
                          basicBlock remove: instruction]]]]! !

!Function methodsFor: 'redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
eliminateRedundandies
  | available redundant substitutions |
  available _ ScopedExpressionDictionary new: 64.
  substitutions _ Dictionary new: 64.
  entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        available pushScope.
        basicBlock
          do:
            [:instruction |
              1
                to: instruction inputOperands
                do:
                  [:index |
                    (instruction atInputOperand: index)
                      ifKindOf: Instruction
                      thenDo:
                        [:operand |
                          (substitutions at: operand)
                            ifPresent:
                              [:definition |
                                instruction
                                  atInputOperand: index
                                  put: definition]]].
              instruction mayBeRedundant
                ifTrue:
                  [redundant _ false.
                    available
                      at: instruction
                      ifPresent:
                        [:definition |
                          redundant _ true.
                          1
                            to: instruction inputOperands
                            do:
                              [:index |
                                (instruction atInputOperand: index)
                                  ifKindOf: Instruction
                                  thenDo:
                                    [:operand |
                                      redundant _ redundant &
                                                    (operand == 
                                                      (definition 
                                                        atInputOperand: index))]].
                          redundant
                            ifTrue:
                              [basicBlock remove: instruction.
                                substitutions at: instruction put: definition]].
                    redundant
                      ifFalse:
                        [available at: instruction put: instruction]]]]
    afterAscent:
      [:basicBlock |
        available popScope]! !

!Function methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
eliminateDeadStores
  exit
    doPostDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          doSuccessors:
            [:successor |
              successor anticipatableIn
                ifNotNil:
                  [basicBlock anticipatableIn
                    ifNil:
                      [basicBlock 
                        anticipatableIn: 
                          successor anticipatableIn copy]
                    ifNotNil:
                      [basicBlock anticipatableIn
                        do:
                          [:storage |
                            (successor anticipatableIn includes: storage)
                              ifFalse:
                                [basicBlock anticipatableIn 
                                  remove: storage]]]]].
        basicBlock anticipatableIn
          ifNil:
            [basicBlock anticipatableIn: Set new].
        basicBlock
          reverseDo:
            [:instruction |
              instruction isUse
                ifTrue:
                  [instruction
                    doInputOperands:
                      [:operand |
                        basicBlock anticipatableIn
                          remove: operand
                          ifAbsent: []]
                    if:
                      [:operand | operand mayLinkDefinitionsToUse]].
              instruction mayBeDead
                ifTrue:
                  [(basicBlock anticipatableIn 
                    includes: 
                      instruction outputOperand)
                    ifTrue:
                      [basicBlock remove: instruction]
                    ifFalse:
                      [basicBlock anticipatableIn 
                        add: 
                          instruction outputOperand]]]]! !

!Function methodsFor: 'unused code removal' stamp: 'lrs 05/26/2002 11:14'!
removeUnusedCode
  | used |
  used _ Set new: 1024.
  entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          do:
            [:instruction |
              instruction mayBeUnused
                ifFalse:
                  [instruction markUsedCode: used]]].
  entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          do:
            [:instruction |
              (instruction mayBeUnused
                and:
                  [(used includes: instruction) not])
                ifTrue:
                  [basicBlock remove: instruction]]]! !

Object subclass: #SSAAnalyzer
  instanceVariableNames: 'function '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Analyses'!

!SSAAnalyzer methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function
  ^ function! !

!SSAAnalyzer methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function: aFunction
  function _ aFunction! !

!SSAAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
detectAliases
  | explicitAliases aliasedLocation memoryLocations |
  explicitAliases _ function memoryLocations copy.
  memoryLocations _ Dictionary new: 64. 
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          do:
            [:instruction |
              instruction mayHaveAliases
                ifTrue:
                  [aliasedLocation _ instruction aliasedLocation.
                    instruction
                      useMemoryLocation:
                        (memoryLocations
                          at: aliasedLocation
                          ifAbsentPut: 
                            [function memoryLocations
                              add: aliasedLocation])]]].
  function memoryLocations
    do:
      [:memoryLocation |
        function memoryLocations
          do:
            [:alias |
              ((memoryLocation aliases: alias) not
                and:
                  [(explicitAliases includes: memoryLocation) not
                    or: [(explicitAliases includes: alias) not]]
                and:
                  [memoryLocation mayAlias: alias])
                ifTrue:
                  [memoryLocation aliases add: alias.
                    alias aliases add: memoryLocation]]]! !

!SSAAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
insertAliases
  function memoryLocations
    do:
      [:memoryLocation |
        function entry
          addFirst:
            (ClobberInstruction new
              operands: (Array with: memoryLocation))].
  function globalVariables
    do:
      [:globalVariable |
        function entry
          addFirst:
            (ClobberInstruction new
              operands: (Array with: globalVariable))].
  function memoryLocations
    do:
      [:memoryLocation |
        function exit
          add:
            (UseInstruction new
              operands: (Array with: memoryLocation))].
  function globalVariables
    do:
      [:globalVariable |
        function exit
          add:
            (UseInstruction new
              operands: (Array with: globalVariable))].
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          do:
            [:instruction |
              instruction insertAliases]]! !

!SSAAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
insertMergesFor: aStorage at: aBasicBlock
  | merge |
  merge _ aBasicBlock first.
  [(merge isKindOf: MergeInstruction)
    and:
      [(merge outputOperand == aStorage) not]]
    whileTrue:
      [merge _ merge nextElement].
  (merge isKindOf: MergeInstruction)
    ifFalse:
      [aBasicBlock
        addFirst:
          (MergeInstruction new
            operands:
              ((Array new: frontier labelOperands)
                at: 1 put: aStorage;
                yourself))]! !

!SSAAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
insertMerges
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          do:
            [:instruction |
              basicBlock
                doDominanceFrontier:
                  [:frontier |
                    instruction
                      doOutputOperands:
                        [:operand |
                          self insertMergesFor: operand at: frontier]
                      if: [:operand | operand mayLinkUsesToDefinition]]]]! !

!SSAAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
linkUsesToDefinitions
  | namespace index merge |
  namespace _ ScopedDictionary new: 64.
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        namespace pushScope.
        basicBlock
          do:
            [:instruction |
              instruction linkUsesToDefinitions: namespace].
        basicBlock
          doSuccessors:
            [:successor |
              index _ successor indexOfPredecessor: basicBlock.
              merge _ successor first.
              [merge isKindOf: MergeInstruction]
                whileTrue:
                  [merge 
                    atInputOperand: index 
                    put: (namespace at: merge outputOperand).
                    merge _ merge nextElement]]]
    afterAscent:
      [:basicBlock |
        namespace popScope]! !

!SSAAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
repairLostCopies
  | namespace |
  namespace _ ScopedDictionary new: 64.
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        namespace pushScope.
        basicBlock instructions
          do:
            [:instruction |
              instruction
                doInputOperands:
                  [:operand |
                    namespace
                      at: operand outputOperand
                      ifPresent:
                        [:definition |
                          operand == definition
                            ifFalse:
                              [operand
                                outputOperand:
                                  (self
                                    allocateLocalVariable:
                                      operand outputOperand storageType)]]]
                ifKindOf: Instruction.
              instruction
                doOutputOperands:
                  [:operand |
                    namespace at: operand put: instruction]
                if: [:operand | operand mayLinkUsesToDefinitions]]]
    afterAscent:
      [:basicBlock |
        namespace popScope]! !

!SSAAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
unlinkUsesFromDefinitions
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock
          do:
            [:instruction |
              (instruction isKindOf: PseudoInstruction)
                ifTrue:
                  [basicBlock remove: instruction]
                ifFalse:
                  [instruction operands
                    withIndexDo:
                      [:operand :index |
                        (operand isKindOf: Instruction)
                          ifTrue:
                            [instruction operands
                              at: index
                              put: operand outputOperand]]]]]! !

!SSAAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
splitCriticalEdgesFor: aBasicBlock
  | merge index newBasicBlock |
  (aBasicBlock countPredecessors > 1
    or:
      [aBasicBlock first isKindOf: MergeInstruction])
    ifFalse:
      [^ self].
  index _ 1.
  aBasicBlock entrances copy
    do:
      [:entrance |
        merge _ aBasicBlock first.
        [(merge isKindOf: MergeInstruction)
          and:
            [(merge atInputOperand: index) isKindOf: Instruction] 
          and:
            [merge outputOperand == 
              (merge atInputOperand: index) outputOperand]]
          whileTrue:
            [merge _ merge nextElement].
        (entrance labelOperands > 1 
          and: 
            [merge isKindOf: MergeInstruction])
          ifTrue:
            [entrance
              doInputOperands:
                [:label |
                  aBasicBlock entrances remove: entrance ifAbsent: [].
                  newBasicBlock _ BasicBlock new.
                  newBasicBlock 
                    region: 
                      (Region new 
                        function: function;
                        depth: entrance basicBlock region depth + 1).
                  newBasicBlock region
                    loop:
                      ((entrance basicBlock region loop == aBasicBlock region loop
                        or:
                          [entrance basicBlock region loop isNil])
                        ifTrue:
                          [entrance basicBlock region loop]
                        ifFalse:
                          [entrance basicBlock region loop parent]).
                  newBasicBlock region loop
                    ifNotNilDo:
                      [:loop |
                        loop body add: newBasicBlock].
                  newBasicBlock
                    addLast:
                      (JumpInstruction new
                        operands:
                          (Array 
                            with: 
                              (BasicBlockLabel new target: aBasicBlock))).
                  label target: newBasicBlock]
              ifKindOf: BasicBlockLabel]]! !

!SSAAnalyzer methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
insertCopiesFor: aBasicBlock
  | used copies remap workList copy operand temporary merge index |
  used _ Set new.
  copies _ OrderedCollection new.
  remap _ Dictionary new.
  workList _ OrderedCollection new.
  aBasicBlock
    doSuccessors:
      [:successor |
        index _ successor indexOfPredecessor: aBasicBlock.
        merge _ successor first.
        [merge isKindOf: MergeInstruction]
          whileTrue:
            [operand _ merge atInputOperand: index.
              (operand isKindOf: Instruction)
                ifTrue:
                  [merge outputOperand == operand outputOperand
                    ifFalse:
                      [used add: operand outputOperand.
                        copies
                          add:
                            (Array
                              with: merge outputOperand
                              with: operand outputOperand)]]
                ifFalse:
                  [copies
                    add:
                      (Array
                        with: merge outputOperand
                        with: operand)].
              merge _ merge nextElement]].
  copies
    do:
      [:nextCopy |
        (used includes: (nextCopy at: 1))
          ifFalse:
            [workList add: nextCopy.
              copies remove: nextCopy]].
  [workList notEmpty or: [copies notEmpty]]
    whileTrue:
      [[workList notEmpty]
        whileTrue:
          [copy _ workList removeLast.
            operand _ copy at: 2.
            remap
              at: operand
              ifPresent:
                [:newOperand |
                  copy at: 2 put: newOperand].
            aBasicBlock add: (MoveInstruction new operands: copy).
            (operand isKindOf: Instruction)
              ifTrue:
                [remap at: operand put: (copy at: 1).
                  (copies
                    detect: [:nextCopy | (nextCopy at: 1) == operand]
                    ifNone: [])
                    ifNotNilDo:
                      [:nextCopy |
                        workList add: nextCopy]]].
        copies notEmpty
          ifTrue:
            [copy _ copies removeLast.
              workList add: copy.
              temporary _ function
                            allocateLocalVariable:
                              (copy at: 1) storageType.
              aBasicBlock
                add:
                  (MoveInstruction new
                    operands:
                      (Array with: temporary with: (copy at: 1))).
              remap at: (copy at: 1) put: temporary]]! !

Object subclass: #InductionVariable
  instanceVariableNames: 'sequence seed increment tripCount maximum '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Analyses'!

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
sequence
  ^ sequence! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
sequence: aSequenceableCollection
  sequence _ aSequenceableCollection! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
increment
  ^ increment! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
increment: anObject
  increment _ anObject! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
seed
  ^ seed! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
seed: anObject
  seed _ anObject! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
tripCount
  ^ tripCount! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
tripCount: anObject
  tripCount _ anObject! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
maximum
  ^ maximum! !

!InductionVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
maximum: anObject
  maximum _ anObject! !

!InductionVariable methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
loop
  ^ sequence first region loop! !

Object subclass: #Loop
  instanceVariableNames: 'entrance exits body parent children depth inductionVariables'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Analyses'!

!Loop class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!Loop methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  exits _ Set new.
  body _ Set new.
  children _ Set new.
  inductionVariables _ Set new! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
entrance
  ^ entrance! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
entrance: aRegion
  entrance _ aRegion! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
exits
  ^ exits! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
body
  ^ body! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
parent
  ^ parent! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
parent: aLoop
  parent _ aLoop! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
children
  ^ children! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
depth
  ^ depth! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
depth: anInteger
  depth _ anInteger! !

!Loop methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
inductionVariables
  ^ inductionVariables! !

!Loop methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
hasPredictableExit
  (exits size = 1
    and: 
      [exits anyOne isPredictableExit])
    ifTrue:
      [^ exits anyOne].
  ^ nil! !

!Loop methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
canPredictInductionVariable: anInstruction
  self hasPredictableExit
    ifNotNilDo:
      [:predictableExit |
       ^ predictableExit canPredictInductionVariable: anInstruction].
  ^ false! !

!Loop methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
tripCount
  self hasPredictableExit
    ifNotNilDo:
      [:predictableExit |
        ^ predictableExit tripCount].
  ^ nil! !

!Loop methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
insertMaximumFor: anInductionVariable before: anInstruction
  self hasPredictableExit
    ifNotNilDo:
      [:predictableExit |
        ^ predictableExit
            insertMaximumFor: anInductionVariable
            before: anInstruction].
  ^ nil!  !

!Loop methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doNestBefore: aBlock
  aBlock value: self.
  children
    do:
      [:child |
        child doNest: aBlock]! !

!Loop methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doNestAfter: aBlock
  aBlock value: self.
  children
    do:
      [:child |
        child doNest: aBlock].
  aBlock value: self! !

!Loop methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doNest: aBlock
  self doNestBefore: aBlock! !

!Loop methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeDepth
  parent
    ifNil:
      [depth _ 1]
    ifNotNil:
      [depth _ parent depth + 1].
  children
    do:
      [:child |
        child computeDepth]! !

!Loop methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
uniteEntrances
  | entrances newPredecessor |
  entrances _ 0.
  entrance
    doPredecessors:
      [:predecessor |
        (body includes: predecessor)
          ifFalse:
            [entrances _ entrances + 1]].
  entrances > 1
    ifFalse:
      [^ nil].
  newPredecessor _ BasicBlock new region: entrance region.
  entrance region add: newPredecessor before: entrance.
  entrance entrances
    do:
      [:instruction |
        (body includes: instruction basicBlock)
          ifFalse:
            [entrance entrances remove: instruction.
              newPredecessor entrances add: instruction.
              instruction
                doInputOperands:
                  [:label |
                    label target: newPredecessor]
                ifKindOf: BasicBlockLabel]].
  newPedecessor
    addLast:
      (JumpInstruction new
        operands:
          (Array with:
            (BasicBlockLabel new target: entrance))).
  ^ newPredecessor! !

!Loop methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
duplicate: shouldOmitExits
  | remappedInstructions remappedBlocks newBlock newInstruction newRegion merge |
  children notEmpty
    ifTrue:
      [^ self].
  remappedInstructions _ Dictionary new: 64.
  remappedBlocks _ Dictionary new: 64.
  remappedBlocks at: entrance region put: entrance region.
  body
    do:
      [:basicBlock |
        remappedBlocks
          at: basicBlock region
          ifAbsentPut:
            [Region new 
              function: basicBlock region function
              loop: self
              depth: basicBlock region depth].
        newBlock _ BasicBlock new region: (remappedBlocks at: basicBlock region).
        remappedBlocks at: basicBlock put: newBlock].
  body
    do:
      [:basicBlock |
        newBlock _ remappedBlocks at: basicBlock.
        basicBlock
          do:
            [:instruction |
              (shouldOmitExits
                and:
                  [exits includes: instruction])
                ifTrue:
                  [instruction
                    doInputOperands:
                      [:label |
                        (body includes: label target)
                          ifTrue:
                            [newInstruction _ JumpInstruction new
                                                operands:
                                                  (Array with:
                                                    (BasicBlockLabel new 
                                                      target: label target))]]
                    ifKindOf: BasicBlockLabel]
                ifFalse:
                  [newInstruction _ instruction copy.
                    remappedInstructions at: instruction put: newInstruction.
                    newInstruction
                      doInputOperandsWithIndex:
                        [:operand :position |
                          remappedInstructions
                            at: operand
                            ifPresent:
                              [:newOperand |
                                newInstruction 
                                  atInputOperand: position 
                                  put: newOperand]].
                    newInstruction
                      doInputOperands:
                        [:label |
                          remappedBlocks
                            at: label target
                            ifPresent:
                              [:newTarget |
                                basicBlock == entrance
                                  ifFalse:
                                    [label target: newTarget]]]
                      ifKindOf: BasicBlockLabel].
              newBlock addLast: newInstruction]].
  entrance region
    doAllChildren:
      [:region |
        newRegion _ remappedBlocks at: region.
        region == entrance region
          ifFalse:
            [region
              do:
                [:basicBlock |
                  newRegion addLast: (remappedBlocks at: basicBlock)]]].
  entrance region
    do:
      [:basicBlock |
        (body includes: basicBlock)
          ifTrue:
            [entrance region add: (remappedBlocks at: basicBlock) before: entrance]].
  entrance
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        (body includes: basicBlock)
          ifTrue:
            [basicBlock
              doSuccessors:
                [:frontier |
                  (body includes: frontier)
                    ifFalse: 
                      [merge _ frontier first.
                        [merge isKindOf: MergeInstruction]
                          whileTrue:
                            [merge
                              doInputOperandsWithIndex:
                                [:operand :position |
                                  remappedInstructions 
                                    at: operand
                                    ifPresent:
                                      [:newOperand |
                                        merge
                                          atInputOperand: position
                                          put: newOperand]].
                              merge _ merge nextElement]]]]

          ifFalse:
            [basicBlock
              do:
                [:instruction |
                  instruction
                    doInputOperandsWithIndex:
                      [:operand :position |
                        remappedInstructions 
                          at: operand
                          ifPresent:
                            [:newOperand |
                              instruction 
                                atInputOperand: position
                                put: newOperand]]]]]! !

!Loop methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
unroll: anInteger
  | remap size unrollCount merge |
  children isEmpty ifFalse: [^ 0].
  body
    do:
      [:basicBlock |
        basicBlock
          do:
            [:instruction |
              instruction
                doOutputOperands: [:memoryLocation | ^ 0]
                ifKindOf: MemoryLocation.
              size _ size + 1]].
  size > anInteger ifTrue: [^ 0].
  tripCount _ self tripCount.
  unrollCount _ anInteger // size.
  tripCount
    ifNotNil:
      [unrollCount > tripCount
        ifTrue:
          [unrollCount _ tripCount]].
  unrollCount
    timesRepeat:
      [self duplicate: tripCount notNil]
  unrollCount = tripCount
    ifTrue:
      [entrance region loop: parent.
        entrance region
          do:
            [:basicBlock |
              (body includes: basicBlock)
                ifTrue:
                  [entrance region remove: basicBlock]]]! !

Object subclass: #LoopAnalyzer
  instanceVariableNames: 'function lowLinks stack '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Analyses'!

!LoopAnalyzer methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function
  ^ function! !

!LoopAnalyzer methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function: aFunction
  function _ aFunction! !

!LoopAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
findLoopBody: aLoop from: aBasicBlock
  | loop |
  aBasicBlock region loop
    ifNil:
      [aBasicBlock region loop: aLoop].
  loop _ aBasicBlock region loop.
  loop == aLoop
    ifTrue:
      [aLoop body add: aBasicBlock.
        aBasicBlock
          doPredecessors:
            [:predecessor |
              (aLoop body includes: predecessor)
                ifFalse:
                  [self findLoopBody: aLoop from: predecessor]]]
    ifFalse:
      [loop parent
        ifNil:
          [loop parent: aLoop.
            aLoop body addAll: loop body.
            aLoop children add: loop.
            loop entrance
            doPredecessors:
              [:predecessor |
                (loop body includes: predecessor)
                  ifFalse:
                    [self findLoopBody: aLoop from: predecessor]]]]! !

!LoopAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
findLoopFrom: aRegion
  "NOTE: This currently only handles reducible loops."
  | loop |
  aRegion loop
    ifNotNil:
      [^ aRegion loop].
  aRegion first
    doPredecessors:
      [:predecessor |
        predecessor region depth >= aRegion depth
          ifTrue:
            [loop
              ifNil:
                [loop _ Loop new.
                  aRegion loop: loop.
                  loop entrance: self.
                  loop body add: self].
              self findLoopBody: newLoop from: predecessor]].
  aRegion loop body
    do:
      [:basicBlock |
        basicBlock
          doSuccessors:
            [:successor |
              (aRegion loop body includes: successor)
                ifFalse:
                  [aRegion loop exits add: basicBlock last]]]! !

!LoopAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
findLoops
  function entry region
    doAllChildrenAfterAscent:
      [:region |
        self findLoopFrom: region].
  function entry region
    doAllChildren:
      [:region |
        region loop
          ifNotNilDo:
            [:loop |
              (loop parent isNil and: [region == loop entrance])
                ifTrue:
                  [function loopNest add: loop.
                    loop computeDepth]]]! !

!LoopAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
classifyTrivial: anInstruction
  | sequence |
  sequence _ #invariant.
  anInstruction
    doInputOperands:
      [:operand |
        ((operand isKindOf: InductionVariable)
          and: [(sequence = #unknown) not])
          ifTrue:
            [sequence _ #derived]
          ifFalse:
            [sequence _ #(unknown derived invariant)
                          detect:
                            [:type |
                              (sequence = type) | (operand sequence = type)]]].
  (sequence = #derived
    and: [anInstruction mayDeriveInductionVariable not])
    ifTrue:
      [sequence _ #unknown].
  anInstruction sequence: sequence! !

!LoopAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
classifySequence: aSet
  | merges linear inductionVariable increment sequence |
  merges _ 0.
  linear _ true.
  aSet
    do:
      [:instruction |
        linear _ linear or: [instruction isLinearIn: aSet].
        (instruction isKindOf: MergeInstruction)
          ifTrue:
            [increment _ instruction.
              merges _ merges + 1]].
  merges = 1 & linear
    ifTrue:
      [inductionVariable _ InductionVariable new.
        sequence _ OrderedCollection new.
        [sequence notEmpty and: [sequence first isKindOf: MergeInstruction]]
          whileTrue:
            [increment _ increment 
                           detect:
                             [:operand |
                               aSet includes: operand].
              sequence addFirst: increment].
        inductionVariable sequence: sequence.
        inductionVariable 
          seed: 
            inductionVariable sequence first inductionVariableSeed.
        (aSet 
          allSatisfy:
            [:instruction |
              (instruction inductionVariableIncrementIn: aSet)
                isKindOf: Constant])
          ifTrue:
            [inductionVariable
              increment:
                (aSet
                  inject: (Constant new value: 0)
                  into:
                    [:accumulator :instruction |
                      instruction 
                        accumulateInductionVariableIncrementInto: 
                          accumulator])].
        inductionVariable loop inductionVariables add: inductionVariable.
        aSet
          do:
            [:instruction |
              instruction sequence: inductionVariable]]
    ifFalse:
      [aSet
        do:
          [:instruction |
            instruction sequence: #unknown]]! !

!LoopAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
findInductionVariablesFrom: anInstruction
  | lowLink sequence |
  lowLink _ lowLinks size + 1.
  lowLinks at: anInstruction put: lowLink.
  stack addLast: anInstruction.
  anInstruction
    doInputOperands:
      [:operand |
        lowLink _ lowLink
                    min:
                      (lowLinks
                        at: operand
                        ifAbsent:
                          [self findInductionVariablesFrom: operand])]
    ifKindOf: Instruction.
  (lowLinks at: instruction) = lowLink
    ifFalse:
      [^ lowLinks at: instruction put: lowLink]
  stack last == instruction
    ifTrue:
      [stack removeLast classifyTrivial]
    ifFalse:
      [[stack last == instruction]
        whileFalse:
          [sequence add: stack removeLast].
        sequence add: stack removeLast.
        self classifySequence: sequence]! !

!LoopAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
classifyInductionVariables
  lowLinks _ Dictionary new.
  stack _ OrderedCollection new.
  function entry
    doDominatorTreeAfterAscent:
      [:basicBlock |
        basicBlock region loop notNil
          ifTrue:
            [basicBlock
              reverseDo:
                [:instruction |
                  lowLinks
                    at: instruction
                    ifAbsent:
                      [self findInductionVariablesFrom: instruction]]]]! !

!LoopAnalyzer methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
analyzeLoops
  self findLoops.
  self classifyInductionVariables! !

List subclass: #BasicBlock
  instanceVariableNames: 'region entrances exits liveIn liveOut locationIn locationOut freeOut anticipatableIn '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Representation'!

!BasicBlock methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  super initialize.
  entrances _ Set new.
  exits _ Set new! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
region
  ^ region! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
region: aRegion
  region _ aRegion! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
entrances
  ^ entrances! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
exits
  ^ exits! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
liveIn
  ^ liveIn! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
liveIn: aSet
  liveIn _ aSet! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
liveOut
  ^ liveOut! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
liveOut: aSet
  liveOut _ aSet! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
locationIn
  ^ locationIn! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
locationIn: aDictionary
  locationIn _ aDictionary! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
locationOut
  ^ locationOut! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
locationOut: aDictionary
  locationOut _ aDictionary! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
freeOut
  ^ freeOut! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
freeOut: aSet
  freeOut _ aSet! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
anticipatableIn
  ^ anticipatableIn! !

!BasicBlock methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
anticipatableIn: aSet
  anticipatableIn _ aSet! !

!BasicBlock methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
add: newInstruction before: oldInstruction
  oldInstruction == self first
    ifTrue:
      [newInstruction
        index:
          (oldInstruction == self
            ifTrue: [0]
            ifFalse: [oldInstruction index - 16])]
    ifFalse:
      [newInstruction
        index:
          (oldInstruction == self
            ifTrue:
              [oldInstruction previousElement index + 16]
            ifFalse:
              [(oldInstruction index + 
                oldInstruction previousElement index) / 2])].
  newInstruction basicBlock: self.
  (newInstruction isKindOf: ExitInstruction)
     ifTrue:
       [exits add: newInstruction.
         newInstruction
           doOperands:
             [:label |
               label target entrances add: newInstruction]
           ifKindOf: BasicBlockLabel].
  ^ super add: newInstruction before: oldInstruction! !

!BasicBlock methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
add: anInstruction
  self
    reverseDo:
      [:instruction |
        (instruction isKindOf: ExitInstruction)
          ifFalse:
            [^ self add: anInstruction after: instruction]].
  ^ self addFirst: anInstruction! !

!BasicBlock methodsFor: 'removing' stamp: 'lrs 05/26/2002 11:14'!
remove: anInstruction
  (anInstruction isKindOf: ExitInstruction)
    ifTrue:
      [exits remove: anInstruction.
        anInstruction
          doOperands:
            [:label |
              label target entrances remove: newInstruction ifAbsent: []]
          ifKindOf: BasicBlockLabel].
  ^ super remove: anInstruction! !

!BasicBlock methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
unlink
  region remove: self.
  region loop
    ifNotNilDo:
      [:loop |
        (self last isKindOf: ExitInstruction)
          ifTrue:
            [region loop exits remove: self last ifAbsent: []].
        loop body remove: self.
        loop entrance == self
          ifTrue:
            [loop parent
              ifNotNilDo:
                [:parent |
                  parent children remove: loop]]].
  exits
    do:
      [:exit |
        exit
          doInputOperands:
            [:label |
              label target entrances remove: exit ifAbsent: [].
              label target entrances isEmpty
                ifTrue:
                  [label target unlink]]
          ifKindOf: BasicBlockLabel]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doSuccessors: aBlock
  exits
    do:
      [:exit |
        exit
          doOperands:
            [:label |
              aBlock value: label target]
          ifKindOf: BasicBlockLabel]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doSuccessors: visitBlock if: predicateBlock
  self
    doSuccessors:
      [:basicBlock |
        (predicateBlock value: basicBlock)
          ifTrue:
            [visitBlock value: basicBlock]]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
countSuccessors
  | count |
  count _ 0.
  self
    doSuccessors:
      [:successor |
        count _ count + 1].
  ^ count! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
indexOfSuccessor: aBasicBlock
  | index |
  index _ 1.
  self
    doSuccessors:
      [:successor |
        (successor == aBasicBlock)
          ifTrue: [^ index].
        index _ index + 1].
  ^ nil! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doPredecessors: aBlock
  entrances
    do:
      [:entrance |
        aBlock value: entrance basicBlock]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doPredecessors: visitBlock if: predicateBlock
  self
    doPredecessors:
      [:basicBlock |
        (predicateBlock value: basicBlock)
          ifTrue:
            [visitBlock value: basicBlock]]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
countPredecessors
  | count |
  count _ 0.
  self
    doPredecessors:
      [:predecessor |
        count _ count + 1].
  ^ count! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
indexOfPredecessor: aBasicBlock
  | index |
  index _ 1.
  self
    doPredecessors:
      [:predecessor |
        (predecessor == aBasicBlock)
          ifTrue: [^ index].
        index _ index + 1].
  ^ nil! !

!BasicBlock methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
splitBefore: anInstruction
  | newBasicBlock position instruction |
  newBasicBlock _ BasicBlock new region: self region.
  position _ anInstruction.
  [position == self]
    whileFalse:
      [instruction _ position.
        position _ position nextElement.
        self remove: instruction.
        newBasicBlock addLast: instruction].
  self region add: newBasicBlock after: self.
  self region loop
    ifNotNilDo:
      [:loop |
        loop body add: newBasicBlock].
  self 
    addLast:
      (JumpInstruction new
        operands:
          (Array with:
            (BasicBlockLabel new target: newBasicBlock))).
  ^ newBasicBlock!  !

!BasicBlock methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
splitAfter: anInstruction
  ^ self splitBefore: anInstruction nextElement! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
findCommonAncestorsWith: aBasicBlock thenDo: aBlock
  | dominator dominatee |
  dominator _ self.
  dominatee _ aBasicBlock.
  [dominator region depth > dominatee region depth]
    whileTrue:
      [dominator region first
        doPrecessors:
          [:predecessor |
            predecessor region depth < depth
              ifTrue:
                [dominator _ predecessor]]].
  [dominatee region depth > dominator region depth]
    whileTrue:
      [dominatee region first
        doPrecessors:
          [:predecessor | 
            predecessor region depth < depth
              ifTrue:
                [dominatee _ predecessor]]].
  [dominator region == dominatee region]
    whileFalse:
      [dominator region first
        doPrecessors:
          [:predecessor | 
            predecessor region depth < depth
              ifTrue:
                [dominator _ predecessor]].
        dominatee region first
          doPrecessors:
            [:predecessor | 
              predecessor region depth < depth
                ifTrue:
                  [dominatee _ predecessor]]].
  ^ aBlock value: dominator value: dominatee! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
dominates: aBasicBlock
  "FIX ME: Make this properly handle loop entrances."
  self
    findCommonAncestorsWith: aBasicBlock
    thenDo:
      [:dominator :dominatee |
        dominator region
          do:
            [:basicBlock | 
              basicBlock == dominator
                ifTrue:
                  [^ true]. 
              basicBlock == dominatee
                ifFalse:
                  [^ false]]]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
postDominates: aBasicBlock
  "FIX ME: Make this properly handle loop entrances."
  self
    findCommonAncestorsWith: aBasicBlock
    thenDo:
      [:postDominator :postDominatee |
        postDominator region
          reverseDo:
            [:basicBlock |  
              basicBlock == postDominator
                ifTrue:
                  [^ true].
              basicBlock == postDominatee
                ifFalse:
                  [^ false]]]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doDominanceFrontier: aBlock of: aBasicBlock
  | frontier |
  self
    doSuccessors:
      [:successor | 
        successor region depth <= aBasicBlock region depth
          ifTrue:
            [aBlock value: successor]
          ifFalse:
            [successor doDominanceFrontier: aBlock of: aBasicBlock]]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doDominanceFrontier: aBlock
  self doDominanceFrontier: aBlock of: self! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doIteratedDominanceFrontier: aBlock
  self
    doDominanceFrontier:
      [:frontier |
        aBlock value: frontier.
        frontier doIteratedDominanceFrontier: aBlock]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doDominatorTreeBeforeDescent: descentBlock afterAscent: ascentBlock
  descentBlock value: self.
  self
    doSuccessors:
      [:successor |
        (successor region depth > region depth
          or:
            [successor region == region
              and:
                [(successor == self) not]])
          ifTrue:
            [successor 
              doDominatorTreeBeforeDescent: descentBlock
              afterAscent: ascentBlock]].
  ascentBlock value: self! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doDominatorTreeBeforeDescent: descentBlock
  self
    doDominatorTreeBeforeDescent: descentBlock
    afterAscent: [:basicBlock]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doDominatorTreeAfterAscent: ascentBlock
  self
    doDominatorTreeBeforeDescent: [:basicBlock]
    afterAscent: ascentBlock! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doDominatorTree: aBlock
  self
    doDominatorTreeBeforeDescent: aBlock
    afterAscent: [:basicBlock]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doPostDominatorTreeBeforeDescent: descentBlock afterAscent: ascentBlock
  descentBlock value: self.
  self
    doPredecessors:
      [:predecessor |
        (predecessor region depth > region depth
          or:
            [predecessor region == region
              and:
                [(predecessor == self) not]])
          ifTrue:
            [predecessor 
              doPostDominatorTreeBeforeDescent: descentBlock
              afterAscent: ascentBlock]].
  ascentBlock value: self! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doPostDominatorTreeBeforeDescent: descentBlock
  self
    doPostDominatorTreeBeforeDescent: descentBlock
    afterAscent: [:basicBlock]! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doPostDominatorTreeAfterAscent: ascentBlock
  self
    doPostDominatorTreeBeforeDescent: [:basicBlock]
    afterAscent: ascentBlock! !

!BasicBlock methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doPostDominatorTree: aBlock
  self 
    doPostDominatorTreeBeforeDescent: aBlock
    afterAscent: [:basicBlock]! !

!BasicBlock methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
collectExpressions: expressions andDepths: depths andAssignments: assignments andMerges: merges andTests: tests
  self
    do:
      [:instruction |
        instruction mayBeRedundant
          ifTrue:
            [depths
              at: instruction
              put:
                ((instruction expressionDepth: depths)
                  max:
                    (depths
                      at: instruction
                      ifPresent: [:depth | depth]
                      ifAbsent: [0])).
              (expressions
                at: instruction
                ifAbsentPut: [OrderedCollection new])
                addLast: instruction].
        (instruction isKindOf: MergeInstruction)
          ifTrue:
            [(merges
              at: instruction outputOperand
              ifAbsentPut: [OrderedCollection new])
              addLast: instruction].
        instruction mayBeReplaceableTest
          ifTrue:
            [instruction
              doInputOperands:
                [:operand |
                  (tests
                    at: operand outputOperand
                    ifAbsentPut: [OrderedCollection new])
                    addLast: instruction]
              if: [:operand | operand mayLinkUsesToDefinitions]].
        instruction isAssignment
          ifTrue:
            [instruction
              doOutputOperands:
                [:operand |
                  (assignments
                    at: operand
                    ifAbsentPut: [OrderedCollection new])
                    addLast: instruction]
              if: [:operand | operand mayLinkUsesToDefinitions]]]! !

List subclass: #Region
  instanceVariableNames: 'function loop depth '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Representation'!

!Region methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function
  ^ function! !

!Region methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function: aFunction
  function _ aFunction! !

!Region methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
loop 
  ^ loop! !

!Region methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
loop: aLoop
  loop _ aLoop! !

!Region methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
depth
  ^ depth! !

!Region methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
depth: anInteger
  depth _ anInteger! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doChildren: aBlock
  self
    do:
      [:basicBlock |
        basicBlock
          doSuccessors:
            [:successor |
              successor region depth > depth
                ifTrue:
                  [aBlock value: successor region]]]! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
detectChild: predicateBlock ifNone: failBlock
  self
    doChildren:
      [:child |
        (predicateBlock value: child)
          ifTrue:
            [^ child]].
  ^ failBlock value! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
detectChild: aBlock
  ^ self detectChild: aBlock ifNone: []! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
parent
  self first
    doPrecessors:
      [:predecessor |
        predecessor region depth < depth
          ifTrue:
            [^ predecessor region]].
  ^ nil! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doAllChildrenBeforeDescent: descentBlock afterAscent: ascentBlock
  descentBlock value: self.
  self 
    doChildren:
       [:child |
         child
           doAllChildrenBeforeDescent: descentBlock
           afterAscent: ascentBlock].
  ascentBlock value: self! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doAllChildrenBeforeDescent: aBlock
  self doAllChildrenBeforeDescent: aBlock afterAscent: [:region :instruction]! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doAllChildrenAfterAscent: aBlock
  self doAllChildrenBeforeDescent: [:region :instruction] afterAscent: aBlock! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doAllChildren: aBlock
  self doAllChildrenBeforeDescent: aBlock afterAscent: [:region :instruction]! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doForwardDataflow: aBlock
  ((loop notNil and: [loop entrance == self])
    ifTrue: [2]
    ifFalse: [1])
    timesRepeat:
      [self
        do:
          [:basicBlock |
            aBlock value: basicBlock.
            basicBlock
              doSuccessors:
                [:successor |
                  successor region depth > depth
                    ifTrue:
                      [successor region doForwardDataflow: aBlock]]]]! !

!Region methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doBackwardDataflow: aBlock
  ((loop notNil and: [loop entrance == self])
    ifTrue: [2]
    ifFalse: [1])
    timesRepeat:
      [self
        reverseDo:
          [:basicBlock |
            basicBlock
              doSuccessors:
                [:successor |
                  successor region depth > depth
                    ifTrue:
                      [successor region doBackwardDataflow: aBlock]].
            aBlock value: basicBlock]]! !

ListElement subclass: #Instruction
  instanceVariableNames: 'basicBlock operands sequence index '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!Instruction class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!Instruction methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  sequence _ #unknown! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock
  ^ basicBlock! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock: aBasicBlock
  basicBlock _ aBasicBlock! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
operands
  ^ operands! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
operands: anArray
  operands _ anArray! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
sequence
  ^ sequence! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
sequence: anObject
  sequence _ anObject! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
index
  ^ index! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
index: aNumber
  index _ aNumber! !

!Instruction methodsFor: 'copying' stamp: 'lrs 05/26/2002 11:14'!
copy
  ^ self class new operands: operands copy! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
region
  ^ basicBlock region! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
depth
  ^ basicBlock region depth! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 0! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
inputOperands
  ^ operands size - self outputOperands! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doInputOperands: aBlock
  operands
    from: self outputOperands + 1
    to: operands size
    do: aBlock!  !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doInputOperandsWithIndex: aBlock
  1 
    to: self inputOperands
    do:
      [:position | 
        aBlock value: (self atInputOperand: position) value: position]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doInputOperands: valueBlock if: predicateBlock
  self
    doInputOperands:
      [:operand |
        (predicateBlock value: operand)
          ifTrue:
            [valueBlock value: operand]]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doInputOperands: aBlock ifKindOf: aClass
  self
    doInputOperands:
      [:operand |
        (operand isKindOf: aClass)
          ifTrue:
            [aBlock value: operand]]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOutputOperands: aBlock
  operands
    from: 1
    to: self outputOperands
    do: aBlock! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOutputOperandsWithIndex: aBlock
  1
    to: self outputOperands
    do:
      [:position |
        aBlock value: (self atOutputOperand: position) value: position]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOutputOperands: valueBlock if: predicateBlock
  self
    doOutputOperands:
      [:operand |
        (predicateBlock value: operand)
          ifTrue:
            [valueBlock value: operand]]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOutputOperands: aBlock ifKindOf: aClass
  self
    doOutputOperands:
      [:operand |
        (operand isKindOf: aClass)
          ifTrue:
            [aBlock value: operand]]! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
outputOperand
  ^ operands at: 1! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
outputOperand: anObject
  operands at: 1 put: anObject! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
atInputOperand: anInteger
  ^ operands at: self outputOperands + anInteger! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
atInputOperand: anInteger put: anObject
  ^ operands
      at: self outputOperands + anInteger
      put: anObject! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
atOutputOperand: anInteger
  ^ operands at: anInteger! !

!Instruction methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
atOutputOperand: anInteger put: anObject
  ^ operands
      at: anInteger
      put: anObject! !

!Instruction methodsFor: 'unused code removal' stamp: 'lrs 05/26/2002 11:14'!
markUsedCode: aSet
  self
    doInputOperands:
      [:operand |
        (aSet includes: operand)
          ifFalse:
            [aSet add: operand.
              operand markUsedCode: aSet]]
    ifKindOf: Instruction! !

!Instruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
mayHaveAliases
  ^ false! !

!Instruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
aliasedLocation
  ^ nil! !

!Instruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
useMemoryLocation: aMemoryLocation
! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
isLinearIn: aSet
  ^ false! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
inductionVariableIncrementIn: aSet
  ^ nil! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
inductionVariableSeed
  ^ nil! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
accumulateInductionVariableIncrementInto: aConstant
  ^ aConstant! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
loopInvariantFor: aLoop
  ^ basicBlock region loop isNil | aLoop isNil
      or:
        [(basicBlock region loop depth < aLoop depth) | 
          (sequence = #invariant)]
      or:
        [sequence = #derived
          and:
            [(self derivedFrom: Set new)
              allSatisfy:
                [:inductionVariable |
                  inductionVariable loop depth < aLoop depth]]]! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
derivedFrom: aSet
  (sequence isKindOf: InductionVariable)
    ifTrue:
      [aSet add: inductionVariables]
  sequence = #derived
    ifTrue:
      [self
        doInputOperands:
          [:operand |
            operand derivedFrom: aSet]].
  ^ aSet! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ false! !

!Instruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  self subclassResponsibility! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  self subclassResponsibility! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
inputOperands
  ^ self operands size - self outputOperands! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOutputOperands: aBlock
  operands
    from: 1
    to: self outputOperands
    do: aBlock! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOutputOperands: visitBlock if: predicateBlock
  self 
    doOutputOperands:
      [:operand | 
        (predicateBlock value: operand)
          ifTrue:
            [visitBlock value: operand]]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOutputOperands: aBlock ifKindOf: aClass
  self
    doOutputOperands: aBlock
    if:
      [:operand |
        operand isKindOf: aClass]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doInputOperands: aBlock
  operands
    from: self outputOperands + 1
    to: operands size
    do: aBlock! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doInputOperands: visitBlock if: predicateBlock
  self 
    doInputOperands:
      [:operand |  
        (predicateBlock value: operand)
          ifTrue:
            [visitBlock value: operand]]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doInputOperands: aBlock ifKindOf: aClass
  self
    doInputOperands: aBlock
    if: 
      [:operand |
        operand isKindOf: aClass]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOperands: aBlock
  operands do: aBlock! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOperands: visitBlock if: predicateBlock
  self
    doOperands:
      [:operand |
        (predicateBlock value: operand)
          ifTrue: 
            [visitBlock value: operand]]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
doOperands: aBlock ifKindOf: aClass
  self
    doOperands: aBlock
    if: 
      [:operand |
        operand isKindOf: aClass]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
dominates: anInstruction
  basicBlock == anInstruction basicBlock
    ifTrue:
      [^ index <= anInstruction index]
    ifFalse:
      [^ basicBlock dominates: anInstruction basicBlock]! !

!Instruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
postDominates: anInstruction
  basicBlock == anInstruction basicBlock
    ifTrue:
      [^ index >= anInstruction index]
    ifFalse:
      [^ basicBlock postDominates: anInstruction basicBlock]! !

!Instruction methodsFor: 'copy propagation' stamp: 'lrs 05/26/2002 11:14'!
copyPropagate
  ^ self! !

!Instruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
maySimplify
  ^ false! !

!Instruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  ^ self! !

!Instruction methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
linkUsesToDefinitions: aDictionary
  self
    doInputOperandsWithIndex: 
      [:operand :position |
        operand mayLinkUsesToDefinitions
          ifTrue:
            [aDictionary
              at: operand
              ifPresent:
                [:definition |
                  self atInputOperand: position put: definition]]].
  self 
    doOutputOperandsWithIndex:
      [:operand :position |
        operand mayLinkUsesToDefinitions
          ifTrue:
            [position = 1
              ifTrue:
                [aDictionary at: operand put: self]
              ifFalse:
                [aDictionary
                  at: operand
                  put:
                    (basicBlock
                      add:
                        (ProjectionInstruction new
                          operands:
                            (Array
                              with: operand
                              with: self
                              with: (Constant new value: position)))
                      after: self)]]]! !

!Instruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
expressionHash
  | hash |
  hash _ self class hash.
  self
    doInputOperands:
      [:operand |
        hash _ (hash + operand operandHash) hashMultiply].
  ^ hash! !

!Instruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
expressionCompare: anInstruction
  self class == anInstruction class
    ifFalse:
      [^ false].
  self
    doInputOperandsWithIndex:
      [:operand :position |
        (operand operandCompare: (anInstruction atInputOperand: position))
          ifFalse:
            [^ false]].
  ^ true! !

!Instruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
operandHash
  ^ self outputOperand hash! !

!Instruction methodsFor: 'partial redundncy elimination' stamp: 'lrs 05/26/2002 11:14'!
operandCompare: anInstruction
  ^ self outputOperand == anInstruction outputOperand! !

!Instruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
expressionDepth: anExpressionDictionary
  ^ (operands
      detectMax: [:operand | operand expressionDepth: anExpressionDictionary])
      expressionDepth + 1! !

!Instruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
substituteOperands: aDictionary
  | substitutions |
  substitutions _ 0.
  self
    doInputOperandsWithIndex:
      [:operand :position |
        (operand isKindOf: Instruction)
          ifTrue:
            [aDictionary
              at: operand
              ifPresent:
                [:substitute |
                  substitutions _ substitutions + 1.
                  self atInputOperand: index put: substitute]]].
  ^ substitutions! !

!Instruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
isAssignment
  ^ outputOperands = 1! !

!Instruction methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
isUse
  ^ false! !

!Instruction methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
mayBeDead
  ^ false! !

!Instruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
mayBeRedundant
  outputOperands = 1
    ifFalse: [^ false].
  self
    doInputOperands:
      [:operand |
        (operand isKindOf: Instruction orOf: Constant)
          ifFalse: [^ false]].
  ^ true! !

!Instruction methodsFor: 'unused code removal' stamp: 'lrs 05/26/2002 11:14'!
mayBeUnused
  ^ true! !

!Instruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
strengthReductionCandidate
  ^ false! !

!Instruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
isInjuredBy: anInstruction
  ^ false! !

!Instruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
canAccumulateInjury: anInstruction
  ^ false! !

!Instruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
repairInjury: injuryInstruction fromValue: valueInstruction in: aRedundancyGraph
  ^ nil! !

!Instruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
accumulateInjury: injuryInstruction into: accumulatorInstruction
  ^ nil! !

!Instruction methodsFor: 'linear function test replacement' stamp: 'lrs 05/26/2002 11:14'!
replaceTest: testInstruction fromValue: valueInstruction in: aRedundancyGraph
  ^ nil! !

!Instruction methodsFor: 'linear function test replacement' stamp: 'lrs 05/26/2002 11:14'!
canReplaceTest: anInstruction
  ^ false! !

!Instruction methodsFor: 'linear function test replacement' stamp: 'lrs 05/26/2002 11:14'!
mayBeReplaceableTest
  ^ false! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
isPredictableExit
  ^ false! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
canPredictInductionVariable: anInductionVariable
  ^ false! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
tripCount
  ^ nil! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
insertTripCountBefore: anInstruction
  ^ nil! !

!Instruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
insertMaximumFor: anInductionVariable before: anInstruction
  ^ nil! !

!Instruction methodsFor: 'bounds check hoisting' stamp: 'lrs 05/26/2002 11:14'!
insertDerivationBefore: anInstruction reusing: anExpressionDictionary
  ^ nil! !

!Instruction methodsFor: 'bounds check hoisting' stamp: 'lrs 05/26/2002 11:14'!
mayHoist
  ^ false! !

Instruction subclass: #PseudoInstruction
  instanceVariableNames: '' 
  classVariableNames: '' 
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!PseudoInstruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
mayBeRedundant
  ^ false! !

Instruction subclass: #UnaryInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!UnaryInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!UnaryInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
inputOperands
  ^ 1! !

!UnaryInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
maySimplify
  ^ true! !

!UnaryInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  ^ ((self atInputOperand: 1) isKindOf: Constant)
      ifTrue: [self evaluate: (self atInputOperand: 1)]
      ifFalse: [self]! !

Instruction subclass: #BinaryInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BinaryInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!BinaryInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
inputOperands
  ^ 2! !

!BinaryInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
maySimplify
  ^ true! !

!BinaryInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  ^ (((self atInputOperand: 1) isKindOf: Constant)
      and:
        [(self atInputOperand: 2) isKindOf: Constant])
      ifTrue:
        [self 
          evaluate: (self atInputOperand: 1) 
          with: (self atInputOperand: 2)]
      ifFalse: [self]! !

!BinaryInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
insertDerivationBefore: anInstruction reusing: anExpressionDictionary
  | accumulator increment |
  self
    doInputOperands:
      [:operand |
        (operand isKindOf: Constant)
          ifTrue:
            [increment _ operand]
          ifFalse:
            [accumulator _ operand]].
  (accumulator sequence isKindOf: InductionVariable)
    ifTrue:
      [accumulator _ accumulator sequence loop
                       insertMaximumFor: accumulator sequence
                       before: anInstruction]
    ifFalse:
      [accumulator _ accumulator  
                       insertDerivationBefore: anInstruction
                       reusing: anExpressionDictionary].
  ((accumulator isKindOf: Constant) and: [increment isKindOf: Constant])
    ifTrue:
      [accumulator _ self evaluate: accumulator with: scale]
    ifFalse:
      [accumulator _ self class new
                       operands:
                         (Array
                           with: 
                             (anInstruction basicBlock region function
                               allocateLocalVariable:
                                 accumulator outputOperand storageType)
                           with: accumulator
                           with: scale).
        anExpressionDictionary
          at: accumulator
          ifPresent:
            [:oldAccumulator |
              (oldAccumulator dominates: anInstruction)
                ifTrue:
                  [accumulator _ oldAccumulator]
                ifFalse:
                  [anInstruction basicBlock
                    add: accumulator
                    before: anInstruction.
                    anExpressionDictionary at: accumulator put: accumulator]]
          ifAbsent:
            [anInstruction basicBlock 
              add: accumulator
              before: anInstruction.
             anExpressionDictionary at: accumulator put: accumulator]].
  ^ accumulator! !

!BinaryInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ nil! !

Instruction subclass: #SideEffectInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!SideEffectInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 0! !

!SideEffectInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
sequence
  ^ #unknown! !

!SideEffectInstruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
mayBeRedundant
  ^ false! !

!SideEffectInstruction methodsFor: 'unused code removal' stamp: 'lrs 05/26/2002 11:14'!
mayBeUnused
  ^ false! !

PseudoInstruction subclass: #ClobberInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!ClobberInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!ClobberInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  anAssembler translateClobber: self! !

PseudoInstruction subclass: #UseInstruction
  instanceVariableNames: '' 
  classVariableNames: '' 
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!UseInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 0! !

!UseInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  anAssembler translateUse: self! !

!UseInstruction methodsFor: 'dead code elimination' stamp: 'lrs 05/26/2002 11:14'!
isUse
  ^ true! !

PseudoInstruction subclass: #ProjectionInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!ProjectionInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateProjection: self! !

!ProjectionInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!ProjectionInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperand: anObject
  super outputOperand: anObject.
  (self operands at: 2) at: (self operands at: 3) value put: anObject! !

PseudoInstruction subclass: #MergeInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!MergeInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateMerge: self! !

!MergeInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!MergeInstruction methodsFor: 'copy propagation' stamp: 'lrs 05/26/2002 11:14'!
copyPropagate
  self
    doInputOperands:
      [:operand |
        (operand isKindOf: Constant) and: [operand value = (operands at: 2) value]
          ifFalse:
            [^ self]].
  ^ operands at: 2! !

!MergeInstruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
isAssignment
  ^ false! !

!MergeInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
isLinearIn: aSet
  ^ operands size = 3! !

!MergeInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
inductionVariableIncrementIn: aSet
  ^ Constant new value: 0! !

!MergeInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
inductionVariableSeed
  self basicBlock region loop
    ifNotNilDo:
      [:loop |
        (loop body includes: (operands at: 3) basicBlock region)
          ifTrue:
            [^ operands at: 2]].
  ^ operands at: 3!  !

!MergeInstruction methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
linkUsesToDefinitions: namespace
! !

UnaryInstruction subclass: #NotInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!NotInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateNot: self! !

!NotInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: aConstant
  ^ Constant new value: aConstant value bitInvert! !

BinaryInstruction subclass: #OrInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!OrInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateOr: self! !

!OrInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new value: (firstConstant value bitOr: secondConstant value)! !

BinaryInstruction subclass: #AndInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!AndInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateAnd: self! !

!AndInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new value: (firstConstant value bitAnd: secondConstant value)! !

BinaryInstruction subclass: #XorInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!XorInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateXor: self! !

!XorInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new value: (firstConstant value bitXor: secondConstant value)! !

BinaryInstruction subclass: #LogicalShiftRightInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!LogicalShiftRightInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateLogicalShiftRight: self! !

!LogicalShiftRightInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ (self operands at: 3) isKindOf: Constant! !

!LogicalShiftRightInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new 
      value: 
        ((firstConstant value
          bitShift: secondConstant value negated)
          bitAnd:
            ((1 
              bitShift:
                firstConstant value highBit -
                  secondConstant value) - 1))! !

BinaryInstruction subclass: #LogicalShiftLeftInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!LogicalShiftLeftInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateLogicalShiftLeft: self! !

!LogicalShiftLeftInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ (self operands at: 3) isKindOf: Constant! !

!LogicalShiftLeftInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new value: (firstConstant value bitShift: secondConstant value)! !

BinaryInstruction subclass: #ArithmeticShiftRightInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!ArithmeticShiftRightInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateArithmeticShiftRight: self! !

!ArithmeticShiftRightInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ (self operands at: 3) isKindOf: Constant! !

!ArithmeticShiftRightInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new value: (firstConstant value bitShift: secondConstant value negated)! !

BinaryInstruction subclass: #AddInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!AddInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateAdd: self! !

!AddInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
isLinearIn: aSet
  ^ ((aSet includes: (self operands at: 2))
      and:
        [(self operands at: 3) loopInvariantFor: self basicBlock region loop])
      or:
        [(aSet includes: (self operands at: 3))
          and:
            [(self operands at: 2) loopInvariantFor: self basicBlock region loop]]! !

!AddInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
inductionVariableIncrementIn: aSet
  ^ (aSet includes: (self operands at: 2))
      ifTrue:
        [self operands at: 3]
      ifFalse:
        [self operands at: 2]! !

!AddInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
accumulateInductionVariableIncrementInto: aConstant
  ((self operands at: 3) isKindOf: Constant)
    ifTrue:
      [aConstant value: aConstant value + (self operands at: 3) value]
    ifFalse:
      [aConstant value: aConstant value + (self operands at: 2) value].
  ^ aConstant! !

!AddInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ ((self operands at: 3) isKindOf: Constant)
      or: 
        [(self operands at: 2) isKindOf: Constant]! !

!AddInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  | accumulator increment |
  accumulator _ self operands at: 2.
  ((accumulator isKindOf: AddInstruction orOf: SubtractInstruction)
    and: [(accumulator operands at: 3) isKindOf: Constant])
    ifTrue: [^ self simplifyExpression].
  increment _ self operands at: 3.
  (increment isKindOf: Constant)
    ifFalse: [^ self]. 
  (accumulator isKindOf: AddInstruction)
    ifTrue:
      [increment value: increment value + (accumulator operands at: 3) value]
    ifFalse:
      [increment value: increment value - (accumulator operands at: 3) value].
  self operands at: 2 put: (accumulator operands at: 2).
  ^ self! !

!AddInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new value: firstConstant value + secondConstant value! !

BinaryInstruction subclass: #SubtractInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!SubtractInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateSubtract: self! !

!SubtractInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
isLinearIn: aSet
  ^ (aSet includes: (self operands at: 2))
      and:
        [(self operands at: 3) loopInvariantFor: self basicBlock region loop]! !

!SubtractInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
inductionVariableIncrementIn: aSet
  ^ self operands at: 3! !

!SubtractInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
accumulateInductionVariableIncrementInto: aConstant
  aConstant value: aConstant value - (self operands at: 3) value.
  ^ aConstant! !

!SubtractInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ ((self operands at: 3) isKindOf: Constant)! !

!SubtractInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  | accumulator increment |
  accumulator _ self operands at: 2.
  ((accumulator isKindOf: AddInstruction orOf: SubtractInstruction)
    and: [(accumulator operands at: 3) isKindOf: Constant])
    ifTrue: [^ self simplifyExpression].
  increment _ self operands at: 3.
  (increment isKindOf: Constant)
    ifFalse: [^ self].
  (accumulator isKindOf: SubtractInstruction)
    ifTrue:
      [increment value: increment value + (accumulator operands at: 3) value]
    ifFalse:
      [increment value: increment value - (accumulator operands at: 3) value].
  self operands at: 2 put: (accumulator operands at: 2).
  ^ self! !

!SubtractInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new value: firstConstant value - secondConstant value! !

BinaryInstruction subclass: #MultiplyInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!MultiplyInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateMultiply: self! !

!MultiplyInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  | operand scale bits accumVar incVar accumulator increment |
  ((self atInputOperand: 2) isKindOf: Constant)
    ifTrue:
      [operand _ self atInputOperand: 1.
        scale _ self atInputOperand: 2.
        (operand isKindOf: Constant)
          ifTrue:
            [^ self evaluate: operand with: scale]]
    ifFalse:
      [operand _ self atInputOperand: 2.
        scale _ self atInputOperand: 1.
        (scale isKindOf: Constant)
          ifFalse:
            [^ self]].
  scale value = 0 ifTrue: [^ Constant new value: 0].
  scale value = 1 ifTrue: [^ self atInputOperand: 1].
  (scale value isKindOf: Integer) ifFalse: [^ self].
  bits _ 0.
  0
    to: self outputOperand storageType bitSize - 1
    do:
      [:shiftCount |
        (scale value bitAnd: (1 bitShift: shiftCount)) = 0
          ifFalse:
            [bits _ bits + 1]].
  bits > 3 ifTrue: [^ self].
  accumVar _ self basicBlock region function
               allocateLocalVariable:
                 operand outputOperand storageType.
  scale value lowBit = 1
    ifTrue:
      [accumulator _ MoveInstruction new
                       operands:
                         (Array with: accumVar with: operand)]
    ifFalse:
      [accumulator _ LogicalShiftLeftInstruction new
                       operands:
                         (Array
                           with: accumVar
                           with: operand
                           with: 
                             (Constant new value: scale value lowBit - 1))].
  self basicBlock add: accumulator before: self.
  bits = 1 ifTrue: [^ accumulator].
  incVar _ self basicBlock region function
             allocateLocalVariable:
               operand outputOperand storageType.
  scale value lowBit
    to: self outputOperand storageType bitSize - 1
    do:
      [:shiftCount |
        (scale value bitAnd: (1 bitShift: shiftCount)) = 0
          ifFalse:
            [increment _ self basicBlock
                           add:
                             (LogicalShiftLeftInstruction new
                               operands:
                                 (Array
                                   with: incVar
                                   with: operand
                                   with: (Constant new value: shiftCount)))
                           before: self.
              accumulator _ self basicBlock
                              add:
                                (AddInstruction new
                                  operands:
                                    (Array
                                      with: accumVar
                                      with: accumulator
                                      with: increment))
                              before: self]].
  ^ accumulator! !

!MultiplyInstruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
strengthReductionCandidate
  | instructions |
  instructions _ 0.
  self
    doInputOperands:
      [:operand |
        (operand isKindOf: Instruction)
          ifTrue:
            [instructions _ instructions + 1]
          ifFalse:
            [(operand isKindOf: Constant)
              ifFalse:
                [^ false]]].
  ^ instructions > 0! !

!MultiplyInstruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
isInjuredBy: anInstruction
  | increment scale injury |
  (anInstruction isKindOf: AddInstruction orOf: SubtractInstruction)
    ifFalse:
      [^ false].
  anInstruction operands
    doInputOperands:
      [:operand |
        ((operand isKindOf: Instruction)
          and: [operand outputOperand == anInstruction outputOperand])
          ifTrue:
            [injury _ operand]
          ifFalse:
            [increment _ operand]].
  injury ifNil: [^ false].
  increment ifNil: [^ false].
  (increment isKindOf: Instruction orOf: Constant)
    ifFalse: [^ false].
  self
    doInputOperands:
      [:operand |
        ((operand isKindOf: Instruction)
          and:
            [operand outputOperand == self outputOperand])
          ifFalse:
            [scale _ operand]].
  scale ifNil: [^ false].
  (increment isKindOf: Constant)
    ifTrue:
      [^ (increment value = 1) or: [scale isKindOf: Constant]]
    ifFalse:
      [^ (increment loopInvariantFor: anInstruction basicBlock region loop) 
           and: [scale loopInvariantFor: anInstruction basicBlock region loop]]! !

!MultiplyInstruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
canAccumulateInjury: anInstruction
  ^ (anInstruction operands anySatisfy: [:operand | operand isKindOf: Constant])
      and: 
        [self operands anySatisfy: [:operand | operand isKindOf: Constant]]! !

!MultiplyInstruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
repairInjury: injuryInstruction fromValue: valueInstruction in: aRedundancyGraph
  | increment scale repair |
  increment _ injuryInstruction operands at: 3.
  ((increment isKindOf: Instruction)
    and:
      [increment outputOperand == injuryInstruction outputOperand])
    ifTrue:
      [increment _ injuryInstruction operands at: 2].
  aRedundancyGraph template
    doInputOperands:
      [:operand |
        ((operand isKindOf: Instruction)
          and:
            [operand outputOperand == injuryInstruction outputOperand])
          ifFalse:
            [scale _ operand]].
  (scale isKindOf: Instruction)
    ifTrue:
      [scale _ aRedundancyGraph namespace at: scale outputOperand].
  (increment isKindOf: Constant)
    ifTrue:
      [(scale isKindOf: Constant)
        ifTrue:
          [increment _ increment copy.
            increment value: increment value * scale value]
        ifFalse:
          [increment _ scale]]
    ifFalse:
      [increment _ MultiplyInstruction new
                     operands:
                       (Array
                         with: 
                           (aRedundancyGraph function 
                             allocateLocalVariable: 
                               increment outputOperand storageType)
                         with: scale
                         with: increment).
        injuryInstruction loop
          ifNotNil:
            [injuryInstruction loop entrance
              doPredecessors:
                [:predecessor |
                  (predecessor region depth < injuryInstruction loop entrance region depth)
                    ifTrue:
                      [predecessor add: increment]]]
          ifNil:
            [injuryInstruction basicBlock
              add: increment
              before: injuryInstruction]].
  repair _ injuryInstruction class new.
  repair 
    operands: 
      (Array
        with: valueInstruction outputOperand
        with: valueInstruction
        with: increment).
  injuryInstruction basicBlock
    add: repair 
    after: injuryInstruction.
  ^ repair! !

!MultiplyInstruction methodsFor: 'strength reduction' stamp: 'lrs 05/26/2002 11:14'!
accumulateInjury: injuryInstruction into: accumulatorInstruction
  | increment scale accumulator |
  scale _ self operands detect: [:operand | operand isKindOf: Constant].
  increment _ injuryInstruction operands detect: [:operand | operand isKindOf: Constant].
  accumulator _ accumulatorInstruction operands detect: [:operand | operand isKindOf: constant].
  injuryInstruction class == accumulatorInstruction class
    ifTrue:
      [accumulator value: accumulator value + increment value * scale value]
    ifFalse:
      [accumulator value: accumulator value - increment value * scale value]! !

!MultiplyInstruction methodsFor: 'linear function test replacement' stamp: 'lrs 05/26/2002 11:14'!
canReplaceTest: anInstruction
  ^ (anInstruction isKindOf: BranchLessInstruction)
      and:
        [(anInstruction operands at: 2) 
          loopInvariantFor: 
            anInstruction basicBlock region loop]
      and:
        [((anInstruction operands at: 1) isKindOf: Instruction)
          and:
            [self operands 
              anySatisfy: 
                [:operand |
                  (operand isKindOf: Instruction)
                    and:
                      [operand outputOperand == 
                        (anInstruction operands at: 1) outputOperand]]]]! !

!MultiplyInstruction methodsFor: 'linear function test replacement' stamp: 'lrs 05/26/2002 11:14'!
replaceTest: testInstruction fromValue: valueInstruction in: aRedundancyGraph
  | scale increment bound |
  aRedundancyGraph template
    doInputOperands:
      [:templateOperand |
        testInstruction
          doInputOperands:
            [:testOperand |
              templateOperand outputOperand == testOperand outputOperand
                ifTrue:
                  [increment _ templateOperand]]
          ifKindOf: Instruction.
        templateOperand = increment
          ifFalse:
            [scale _ aRedundancyGraph namespace at: templateOperand outputOperand]]
    ifKindOf: Instruction.
  testInstruction
    doInputOperandsWithIndex:
      [:operand :position |
        (operand isKindOf: Instruction)
          ifTrue:
            [operand outputOperand = increment outputOperand
              ifTrue:
                [testInstruction atInputOperand: position put: valueInstruction]
              ifFalse:
                [bound _ MultiplyInstruction new
                           operands:
                             (Array 
                               with: 
                                 (aRedundancyGraph function
                                   allocateLocalVariable:
                                     scale outputOperand storageType)
                               with: scale
                               with: operand).
                  testInstruction basicBlock
                    add: bound 
                    before: testInstruction.
                  testInstruction atInputOperand: position put: bound]].
        (operand isKindOf: Constant)
          ifTrue:
            [(scale isKindOf: Constant)
              ifTrue:
                [bound _ Constant value: operand value * scale value]
              ifFalse:
                [bound _ MultiplyInstruction new
                           operands:
                             (Array 
                               with:
                                 (aRedundancyGraph function
                                   allocateLocalVariable:
                                     scale outputOperand storageType)
                               with: scale
                               with: operand).
                  testInstruction basicBlock
                    add: bound 
                    before: testInstruction].
              testInstruction atInputOperand: position put: bound]].
  ^ testInstruction! !

!MultiplyInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ (((self operands at: 3) isKindOf: Constant)
        and:
          [(self operands at: 3) value isPowerOfTwo])
      or:
        [((self operands at: 2) isKindOf: Constant)
          and:
            [(self operands at: 2) value isPowerOfTwo]]! !

!MultiplyInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new value: firstConstant value * secondConstant value! !

BinaryInstruction subclass: #DivideInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!DivideInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateDivide: self! !

!DivideInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ ((self operands at: 3) isKindOf: Constant)
        and:
          [(self operands at: 3) value isPowerOfTwo]! !

!DivideInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new
      value: 
        ((firstConstant value isKindOf: Integer) & (secondConstant value isKindOf: Integer)
          ifTrue: [firstConstant value // secondConstant value]
          ifFalse: [firstConstant value / secondConstant value])! !

!DivideInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  (self atInputOperand: 2)
    ifKindOf: Constant
    thenDo:
      [:scale |
        (self atInputOperand: 1)
          ifKindOf: Constant
          thenDo:
            [:operand |
              ^ self evaluate: operand with: scale].
        scale value = 1
          ifTrue: [^ self atInputOperand: 1].
        scale value isPowerOfTwo
          ifTrue:
            [^ self basicBlock
                 add:
                   (ArithmeticShiftRightInstruction new
                     operands:
                       (Array
                         with:
                           (self basicBlock region function
                             allocateLocalVariable:
                               (self atInputOperand: 1) outputOperand storageType)
                         with: (self atInputOperand: 1)
                         with:
                           (Constant new
                             value: scale value lowBit - 1)))
                 before: self]].
  ^ self! !

BinaryInstruction subclass: #RemainderInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!RemainderInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateRemainder: self! !

!RemainderInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  ^ ((self operands at: 3) isKindOf: Constant)
        and:
          [(self operands at: 3) value isPowerOfTwo]! !

!RemainderInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ Constant new
      value: 
        firstConstant value - 
          (firstConstant value * 
            (firstConstant value / secondConstant value) floor)! !

!RemainderInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  (self atInputOperand: 2)
    ifKindOf: Constant
    thenDo:
      [:scale |
        (self atInputOperand: 1)
          ifKindOf: Constant
          thenDo:
            [:operand |
              ^ self evaluate: operand with: scale].
        scale value = 1
          ifTrue: [^ Constant new value: 0].
        scale value isPowerOfTwo
          ifTrue:
            [^ self basicBlock
                 add:
                   (AndInstruction new
                     operands:
                       (Array
                         with:
                           (self basicBlock region function
                             allocateLocalVariable:
                               (self atInputOperand: 1) outputOperand storageType)
                         with: (self atInputOperand: 1)
                         with:
                           (Constant new
                             value: scale value - 1)))
                 before: self]].
  ^ self! !

UnaryInstruction subclass: #MoveInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!MoveInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateMove: self! !

!MoveInstruction methodsFor: 'copy propagation' stamp: 'lrs 05/26/2002 11:14'!
copyPropagate
  ((operands at: 2) isKindOf: Instruction orOf: Constant)
    ifTrue:
      [^ operands at: 2]
    ifFalse:
      [^ self]! !

!MoveInstruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
mayBeRedunant
  ^ false! !

!MoveInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: aConstant
  ^ aConstant! !

!MoveInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  ^ self copyPropagate! !

UnaryInstruction subclass: #TruncateInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!TruncateInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateTruncate: self! !

!TruncateInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: aConstant
  ^ Constant new 
      value: 
        (aConstant value 
          bitAnd: 
            (1 bitShift: self outputOperand storageType bitSize) - 1)! !

UnaryInstruction subclass: #SignExtendInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!SignExtendInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateSignExtend: self! !

!SignExtendInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: aConstant
  ^ aConstant! !

UnaryInstruction subclass: #ZeroExtendInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!ZeroExtendInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateZeroExtend: self! !

!ZeroExtendInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: aConstant
  ^ aConstant! !

UnaryInstruction subclass: #ConvertInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!ConvertInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateConvert: self! !

!ConvertInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: aConstant
  ^ Constant new 
      value:
        ((self outputOperand storageType isKindOf: FloatStorageType)
          ifTrue: [aConstant value asFloat]
          ifFalse: [aConstant value])! !

SideEffectInstruction subclass: #BoundsCheckInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BoundsCheckInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateBoundsCheck: self! !

!BoundsCheckInstruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
mayBeRedundant
  ^ true! !

!BoundsCheckInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
mayDeriveInductionVariable
  | inductionVariables |
  (self operands at: 1)
    ifKindOf: Instruction
    thenDo:
      [:instruction |
        (instruction sequence = #derived 
          or: [instruction sequence isKindOf: InductionVariable])
          ifFalse:
            [^ false].
        inductionVariables _ Set new.
        instruction derivedFrom: inductionVariables.
        inductionVariables
          do:
            [:inductionVariable |
              ((self operands at: 2) loopInvariantFor: inductionVariable loop)
                ifFalse:
                  [^ false]]].
  ^ true! !

!BoundsCheckInstruction methodsFor: 'bounds check hoisting' stamp: 'lrs 05/26/2002 11:14'!
mayHoist
  ^ true! !

!BoundsCheckInstruction methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
insertAliases
  self basicBlock region function memoryLocations
    do:
      [:memoryLocation |
        self basicBlock
          add:
            (UseInstruction new
              operands: (Array with: memoryLocation))
          before: self].
  self basicBlock region function globalVariables
    do:
      [:globalVariable |
        self basicBlock
          add:
            (GlobalVariableInstruction new
              operands: (Array with: globalVariable))
          before: self]! !

SideEffectInstruction subclass: #LoadInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!LoadInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!LoadInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateLoad: self! !

!LoadInstruction methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
insertAliases
  (self operands at: 2) 
    ifKindOf: MemoryLocation
    thenDo:
      [:memoryLocation |
        memoryLocation aliases
          do:
           [:alias |
             self basicBlock region
               add:
                 (UseInstruction new
                   operands: (Array with: alias))
               after: self]]! !

!LoadInstruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
mayHaveAliases
  ^ (self operands at: 2) isKindOf: MemoryAlias! !

!LoadInstruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
aliasedLocation
  ^ MemoryLocation new
      storageType: self outputOperand storageType
      base: (self operands at: 3)
      offset: (self operands at: 4)! !

!LoadInstruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
useMemoryLocation: aMemoryLocation
  self operands at: 2 put: aMemoryLocation! !

!LoadInstruction methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
mayBeRedundant
  ^ true! !

!LoadInstruction methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
isUse
  ^ true! !

!LoadInstruction methodsFor: 'unused code removal' stamp: 'lrs 05/26/2002 11:14'!
mayBeUnused
  ^ true! !

!LoadInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
maySimplify
  ^ true! !

!LoadInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  | accumulator increment |
  ((self operands at: 2) isKindOf: MemoryLocation)
    ifFalse: [^ self].
  accumulator _ self operands at: 3.
  ((accumulator isKindOf: AddInstruction orOf: SubtractInstruction)
    and: [(accumulator operands at: 3) isKindOf: Constant])
    ifTrue: [^ self].
  increment _ self operands at: 4.
  (increment isKindOf: Constant)
    ifFalse: [^ self].
  (accumulator isKindOf: AddInstruction)
    ifTrue:
      [increment value: increment value + (accumulator operands at: 3) value]
    ifFalse:
      [increment value: increment value - (accumulator operands at: 3) value].
  self operands at: 3 put: (accumulator operands at: 2).
  ^ self! !

SideEffectInstruction subclass: #StoreInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!StoreInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!StoreInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateStore: self! !

!StoreInstruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
mayHaveAliases
  ^ (self operands at: 1) isKindOf: MemoryAlias! !

!StoreInstruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
memoryAddress
  ^ MemoryLocation new
      storageType: self outputOperand storageType
      base: (self operands at: 2)
      offset: (self operands at: 3)! !

!StoreInstruction methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
useMemoryLocation: aMemoryLocation
  self operands at: 1 put: aMemoryLocation! !

!StoreInstruction methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
mayBeDead
  ^ true! !

!StoreInstruction methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
insertAliases
  (self operands at: 1)
    ifKindOf: MemoryLocation
    thenDo:
      [:memoryLocation |
        memoryLocation aliases
          do:
            [:alias |
              self basicBlock region
                add:
                  (ClobberInstruction new
                    operands: (Array with: alias))
                after: self]]! !

!StoreInstruction methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
expressionHash
  | hash |
  hash _ self class hash.
  1
    to: self operands size - 1
    do:
      [:position |
        hash _ (hash + (self operands at: position) operandHash) hashMultiply].
  ^ hash! !

!StoreInstruction methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
expressionCompare: anInstruction
  self class == anInstruction class
    ifFalse:
      [^ false].
  1
    to: self operands size - 1
    do:
      [:position |
        ((self operands at: position) 
          operandCompare: 
            (anInstruction operands at: position))
          ifFalse:
            [^ false]].
  ^ true! !

SideEffectInstruction subclass: #PushInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!PushInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translatePush: self! !

SideEffectInstruction subclass: #PopInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!PopInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!PopInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translatePop: self! !

SideEffectInstruction subclass: #AllocateInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!AllocateInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateAllocate: self! !

SideEffectInstruction subclass: #FreeInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!FreeInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateFree: self! !

SideEffectInstruction subclass: #PrologueInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!PrologueInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translatePrologue: self! !

SideEffectInstruction subclass: #EpilogueInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!EpilogueInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateEpilogue: self! !

SideEffectInstruction subclass: #SpillInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!SpillInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!SpillInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateSpill: self! !

SideEffectInstruction  subclass: #ReloadInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!ReloadInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
outputOperands
  ^ 1! !

!ReloadInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateReload: self! !

SideEffectInstruction subclass: #ExitInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!ExitInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
labelOperands
  ^ 0! !

!ExitInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
atLabelOperand: anInteger
  ^ self operands 
      at: 
        (self operands size - self labelOperands) + anInteger! !

!ExitInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
atLabelOperand: anInteger put: anObject
  ^ self operands
      at:
        (self operands size - self labelOperands) + anInteger
      put: anObject! !

ExitInstruction subclass: #JumpInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!JumpInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateJump: self! !

!JumpInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
labelOperands
  ^ 1! !

SideEffectInstruction subclass: #CallInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!CallInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateCall: self! !

!CallInstruction methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
insertAliases
  | calleeGlobalVariables |
  self basicBlock region function memoryLocations
    do:
      [:memoryLocation |
        self basicBlock
          add:
            (UseInstruction new
              operands: (Array with: memoryLocation))
          before: self.
        self basicBlock
          add:
            (ClobberInstruction new
              operands: (Array with: memoryLocation))
          after: self].
  (self operands at: 1)
    ifKindOf: FunctionLabel
    thenDo:
      [:label |
        calleeGlobalVariables _ label target globalVariables].
  self basicBlock region function globalVariables
    do:
      [:globalVariable |
        (calleeGlobalVariables isNil
          or:
            [calleeGlobalVariables includes: globalVariable])
          ifTrue:
            [self basicBlock
              add:
                (UseInstruction new
                  operands: (Array with: globalVariable))
              before: self.
              self basicBlock
                add:
                  (ClobberInstruction new
                    operands: (Array with: globalVariable))
                after: self]]! !

ExitInstruction subclass: #ReturnInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!ReturnInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateReturn: self! !

ExitInstruction subclass: #BranchInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BranchInstruction methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
labelOperands
  ^ 2! !

!BranchInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
maySimplify
  ^ true! !

!BranchInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  self subclassResponsibility! !

!BranchInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
simplifyExpression
  | x y path unlinked  |
  x _ self atInputOperand: 1.
  y _ self atInputOperand: 2.
  ((x isKindOf: Constant) and: [y isKindOf: Constant]) 
    ifFalse:
      [^ self].
   (self evaluate: x with: y)
     ifTrue: 
       [path _ self atInputOperand: 3.
         unlinked _ self atInputOperand: 4]
     ifFalse: 
       [path _ self atInputOperand: 4.
         unlinked _ self atInputOperand: 3].
  self basicBlock remove: self.
  self basicBlock
    addLast: (JumpInstruction new operands: (Array with: path)).
  unlinked target entrances isEmpty
    ifTrue:
      [unlinked target unlink].
  self basicBlock region loop
    ifNotNilDo:
      [:loop |
        loop exits remove: self ifAbsent: [].
        (loop body includes: path target)
          ifFalse:
            [loop exits add: self basicBlock last]].
  (self basicBlock region loop == path target region loop
    and:
      [path target entrances size = 1])
    ifTrue:
      [path target region
        do:
          [:pathBasicBlock |
            pathBasicBlock region: self basicBlock region].
        self basicBlock region concatenateLast: path target region].
  ^ self basicBlock last! !

BranchInstruction subclass: #BranchEqualInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BranchEqualInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateBranchEqual: self! !

!BranchEqualInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ firstConstant value = secondConstant value! !

BranchInstruction subclass: #BranchNotEqualInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BranchNotEqualInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateBranchNotEqual: self! !

!BranchNotEqualInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ firstConstant value ~= secondConstant value! !

Instruction  subclass: #BranchLessInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BranchLessInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateBranchLess: self! !

!BranchLessInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ firstConstant value < secondConstant value! !

!BranchLessInstruction methodsFor: 'linear function test replacement' stamp: 'lrs 05/26/2002 11:14'!
mayBeReplaceableTest
  ^ ((self operands at: 1) isKindOf: Instruction)
      and:
        [(self operands at: 2) loopInvariantFor: self basicBlock region loop]! !

!BranchLessInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
isPredictableExit
  (((self operands at: 2) loopInvariantFor: self basicBlock region loop)
    and:
      [(self operands at: 3) target == self basicBlock region loop entrance])
    ifFalse:
      [^ false].
  (self operands at: 1) sequence
    ifKindOf: InductionVariable
    thenDo:
      [:inductionVariable |
        ^ (inductionVariable increment isKindOf: Constant)
            and:
              [inductionVariable increment value > 0]
            and: 
              [(inductionVariable increment value isPowerOfTwo)
                or:
                  [(self operands at: 2) isKindOf: Constant]]].
  ^ false! !

!BranchLessInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
canPredictInductionVariable: anInductionVariable
  ^ (anInductionVariable == (operands at: 1) sequence)
      or:
       [(anInductionVariable increment isKindOf: Constant)
         and:
           [anInductionVariable increment value > 0]
         and:
           [anInductionVariable increment value isPowerOfTwo
             or:
               [tripCount notNil]]]! !

!BranchLessInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
tripCount
  (operands at: 1) sequence seed
    ifKindOf: constant
    thenDo:
      [:seed |
        (operands at: 2)
          ifKindOf: Constant
          thenDo:
            [:bound |
              (operands at: 1) sequence
                tripCount:
                  (Constant new 
                    value: 
                      (bound value - seed value) / 
                        (operands at: 1) sequence increment value)]].
  ^ (operands at: 1) sequence tripCount
      ifKindOf: Constant
      thenDo:
        [:tripCount | tripCount copy]! !

!BranchLessInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
insertTripCountBefore: anInstruction
  | tripCount |
  (operands at: 1) sequence tripCount
    ifNotNil:
      [^ (operands at: 1) sequence tripCount copy].
  (((operands at: 1) sequence seed isKindOf: Constant)
    and:
      [(operands at: 1) sequence seed value = 0])
    ifTrue:
      [tripCount _ operands at: 2]
    ifFalse:
      [tripCount _ SubtractInstruction new
                     operands:
                       (Array
                         with:
                           (anInstruction basicBlock region function
                             allocateLocalVariable:
                               (operands at: 2) outputOperand storageType)
                         with: (operands at: 2)
                         with: (operands at: 1) sequence seed)
        anInstruction basicBlock
          add: tripCount
          before: anInstruction].
  inductionVariable increment value = 1
    ifFalse:
      [tripCount _ LogicalShiftRightInstruction new
                     operands:
                       (Array
                         with: 
                           (tripCount = (operands at: 2)
                             ifTrue:
                               [anInstruction basicBlock region function
                                 allocateLocalVariable:
                                   (operands at: 2) outputOperand storageType]
                             ifFalse:
                               [tripCount outputOperand])
                         with: tripCount
                         with: 
                           (Constant new 
                             value: 
                               inductionVariable increment value lowBit - 1)).
        anInstruction basicBlock
          add: tripCount
          before: anInstruction].
  (operands at: 1) sequence tripCount: tripCount.
  ^ tripCount! !

!BranchLessInstruction methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
insertMaximumFor: anInductionVariable before: anInstruction
  | maximum |
  (operands at: 1) sequence maximum
    ifNotNil:
      [^ (operands at: 1) sequence maximum copy].
  anInductionVariable == (operands at: 1) sequence
    ifTrue:
      [((operands at: 2) isKindOf: Constant)
        ifTrue:
          [maximum _ Constant new value: (operands at: 2) value - 1]
        ifFalse:
          [inductionVariable increment value = 1
            ifTrue:
              [maximum _ anInstruction basicBlock
                           add:
                             (SubtractInstruction new
                               operands:
                                 (Array
                                   with: 
                                     (anInstruction basicBlock region function
                                       allocateLocalVariable:
                                         (operands at: 2) storageType)
                                   with: (operands at: 2)
                                   with: (Constant new value: 1)))
                           before: anInstruction]
            ifFalse:
              [self tripCount
                ifNotNilDo:
                  [:tripCount |
                    maximum _ tripCount 
                                value: 
                                  (tripCount value - 1) * 
                                    anInductionVariable increment value
                                      + anInductionVariable seed value]]]]
    ifFalse:
      [self tripCount
        ifNotNilDo:
          [:tripCount |
            tripCount 
              value: 
                (tripCount value - 1) *
                  anInductionVariable increment value.
            (anInductionVariable seed value isKindof: Constant)
              ifTrue:
                [maximum _ tripCount 
                             value: 
                               tripCount value + 
                                 anInductionVariable seed value]
              ifFalse:
                [maximum _ anInstruction basicBlock
                             add:
                               (AddInstruction new
                                 operands:
                                   (Array
                                     with: 
                                       (anInstruction basicBlock region function
                                         allocateLocalVariable:
                                           anInductionVariable seed storageType)
                                     with: anInductionVariable seed
                                     with: tripCount))
                             before: anInstruction]]].
  maximum
    ifNil:
      [maximum _ self insertTripCountBefore: anInstruction.
        maximum _ anInstruction basicBlock
                    add:
                      (SubtractInstruction new
                        operands:
                          (Array
                            with:
                              (anInstruction basicBlock region function
                                allocateLocalVariable:
                                  maximum outputOperand storageType)
                            with: maximum
                            with: (Constant new value: 1)))
                    before: anInstruction.
        anInductionVariable increment value = 1
          ifFalse:
            [maximum _ anInstruction basicBlock
                         add:
                           (LogicalShiftLeftInstruction new
                             operands:
                               (Array 
                                 with: maximum outputOperand
                                 with: maximum
                                 with: 
                                   (Constant new
                                     value: anInductionVariable increment value lowBit - 1)))
                         before: anInstruction].
        ((anInductionVariable seed isKindOf: Constant)
          and:
            [anInductionVariable seed value = 0])
          ifFalse:
            [maximum _ anInstruction basicBlock
                         add:
                           (AddInstruction new
                             operands:
                               (Array
                                 with: maximum outputOperand
                                 with: maximum
                                 with: anInductionVariable seed))
                         before: anInstruction]].
  anInductionVariable sequence maximum: maximum.
  ^ maximum! !

BranchInstruction subclass: #BranchLessEqualInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BranchLessEqualInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateBranchLessEqual: self! !

!BranchLessEqualInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ firstConstant value <= secondConstant value! !

BranchInstruction subclass: #BranchGreaterInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BranchGreaterInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateBranchGreater: self! !

!BranchGreaterInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ firstConstant value > secondConstant value! !

BranchInstruction  subclass: #BranchGreaterEqualInstruction
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Instructions'!

!BranchGreaterEqualInstruction methodsFor: 'translating' stamp: 'lrs 05/26/2002 11:14'!
translateOn: aTranslator
  aTranslator translateBranchGreaterEqual: self! !

!BranchGreaterEqualInstruction methodsFor: 'expression simplification' stamp: 'lrs 05/26/2002 11:14'!
evaluate: firstConstant with: secondConstant
  ^ firstConstant value >= secondConstant value! !

Object subclass: #StorageType
  instanceVariableNames: 'bitSize '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!StorageType methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
bitSize
  ^ bitSize! !

!StorageType methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
bitSize: anInteger
  bitSize _ anInteger! !

!StorageType methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
byteSize
  ^ (bitSize + 7) / 8! !

!StorageType methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
byteSizeSize: anInteger
  byteSize _ bitSize * 8! !

!StorageType methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
mayContain: aStorageType
  ^ (aStorageType isKindOf: self class)
      and: [aStorageType bitSize <= bitSize]! !

!StorageType methodsFor: 'comparing' stamp: 'lrs 05/26/2002 11:14'!
= aStorageType
  ^ self class = aStorageType class
      and: [bitSize = aStorageType bitSize]! !

StorageType subclass: #ConditionStorageType
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

StorageType subclass: #FloatStorageType
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

StorageType subclass: #IntegerStorageType
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

IntegerStorageType subclass: #PointerStorageType
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

Object subclass: #LiveRange 
  instanceVariableNames: 'start end '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Register Allocation'!

!LiveRange methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
start
  ^ start! !

!LiveRange methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
start: anInteger
  start _ anInteger! !

!LiveRange methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
end
  ^ end! !

!LiveRange methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
end: anInteger
  end _ anInteger! !

Object subclass: #Storage
  instanceVariableNames: 'storageType '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!Storage methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
storageType
  ^ storageType! !

!Storage methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
storageType: aStorageType
  storageType _ aStorageType! !

!Storage methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
sequence
  ^ #unknown! !

!Storage methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
loopInvariantFor: aLoop
  ^ self sequence = #invariant! !

!Storage methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
mayLinkUsesToDefinitions
  ^ false! !

!Storage methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
mayLinkDefinitionsToUses
  ^ false! !

!Storage methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
operandHash
  ^ self hash! !

!Storage methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
operandCompare: aStorage
  ^ self == aStorage! !

!Storage methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
expressionDepth: anExpressionDictionary
  ^ 0! !

Storage subclass: #Constant
  instanceVariableNames: 'value '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!Constant methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
value
  ^ value! !

!Constant methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
value: anObject
  value _ anObject! !

!Constant methodsFor: 'loop analysis' stamp: 'lrs 05/26/2002 11:14'!
sequence
  ^ #invariant! !

!Constant methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
operandHash
  ^ self class hash + value hash! !

!Constant methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
operandCompare: aConstant
  ^ self class == aConstant class
      and: [value = aConstant value]! !

!Constant methodsFor: 'comparing' stamp: 'lrs 05/26/2002 11:14'!
= aConstant
  ^ self class == aConstant class
      and: [value = aConstant value]! !

Storage subclass: #Label
  instanceVariableNames: 'target '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!Label methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
target
  ^ target! !

!Label methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
target: anObject
  target _ anObject! !

!Label methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
sequence
  ^ #invariant! !

!Label methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
operandHash
  ^ self class hash + target hash! !

!Label methodsFor: 'partial redundancy elimination' stamp: 'lrs 05/26/2002 11:14'!
operandCompare: aLabel
  ^ target == aLabel target! !

Label subclass: #BasicBlockLabel
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

Label subclass: #FunctionLabel
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

Storage subclass: #MemoryAlias
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

Storage subclass: #MemoryLocation
  instanceVariableNames: 'base offset aliases '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!MemoryLocation class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!MemoryLocation methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  aliases _ Set new! !

!MemoryLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
aliases
  ^ aliases! !

!MemoryLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
aliases: aMemoryLocation
  ^ aliases includes: aMemoryLocation! !

!MemoryLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
base
  ^ base! !

!MemoryLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
base: anInstructionOrConstant
  base _ anInstructionOrConstant! !

!MemoryLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
offset
  ^ offset! !

!MemoryLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
offset: anInstructionOrConstant
  offset _ anInstructionOrConstant! !

!MemoryLocation methodsFor: 'comparing' stamp: 'lrs 05/26/2002 11:14'!
hash
  ^ ((self class hash + storageType hash) hashMultiply + base hash) hashMultiply + offset hash! !

!MemoryLocation methodsFor: 'comparing' stamp: 'lrs 05/26/2002 11:14'!
= aMemoryLocation
  ^ self class == aMemoryLocation class
      and: [storageType = aMemoryLocation storageType]
      and: [base = aMemoryLocation base]
      and: [offset = aMemoryLocation offset]! !

!MemoryLocation methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
mayOverlap: aMemoryLocation
  | start end otherStart otherEnd |
  start _ ((base isKindOf: Constant) 
            ifTrue: [base] 
            ifFalse: [offset]) value.
  end _ start + storageType byteSize.
  otherStart _ ((aMemoryLocation base isKindOf: Constant)
                 ifTrue: [aMemoryLocation base]
                 ifFalse: [aMemoryLocation offset]) value.
  otherEnd _ start + aMemoryLocation storageType byteSize.
  ^ (start >= otherStart and: [start < otherEnd])
      or:
        [end >= otherStart and: [end < otherEnd]]! !

!MemoryLocation methodsFor: 'alias analysis' stamp: 'lrs 05/26/2002 11:14'!
mayAlias: aMemoryLocation
  self == aMemoryLocation ifTrue: [^ false].
  (base isKindOf: Constant)
    ifTrue:
      [(aMemoryLocation base isKindOf: Constant)
        ifTrue:
          [^ self mayOverlap: aMemoryLocation]
        ifFalse: 
          [^ true]].
  (base == aMemoryLocation base
    and: [offset isKindOf: Constant]
    and: [aMemoryLocation offset isKindOf: Constant])
    ifTrue:
      [^ self mayOverlap: aMemoryLocation]
    ifFalse:
      [^ true]! !

!MemoryLocation methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
mayLinkUsesToDefinitions
  ^ true! !

!MemoryLocation methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
mayLinkDefinitionsToUses
  ^ true! !

Storage subclass: #Register
  instanceVariableNames: 'name useCount '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!Register methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
name
  ^ name! !

!Register methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
name: aString
  name _ aString! !

!Register methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
useCount
  ^ useCount! !

!Register methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
useCount: aninteger
  useCount _ anInteger! !

Register subclass: #CompositeRegister
  instanceVariableNames: 'components '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!CompositeRegister methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
components
  ^ components! !

!CompositeRegister methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
components: aRegisterArray
  components _ aRegisterArray! !

Storage subclass: #Variable
  instanceVariableNames: 'offset '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!Variable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
offset
  ^ offset! !

!Variable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
offset: anInteger
  offset _ anInteger! !

Variable subclass: #GlobalVariable
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!GlobalVariable methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
mayLinkUsesToDefinitions
  ^ true! !

!GlobalVariable methodsFor: 'dead store elimination' stamp: 'lrs 05/26/2002 11:14'!
mayLinkDefinitionsToUses
  ^ true! !

Variable subclass: #RegisterVariableLocation
  instanceVariableNames: 'variable register damaged'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Register Allocation'!

!RegisterVariableLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
variable
  ^ variable! !

!RegisterVariableLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
variable: aRegisterVariable
  variable _ aRegisterVariable! !

!RegisterVariableLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
register
  ^ register! !

!RegisterVariableLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
register: aRegister
  register _ aRegister! !

!RegisterVariableLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
damaged
  ^ damaged! !

!RegisterVariableLocation methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
damaged: aBoolean
  damaged _ aBoolean! !

Variable subclass: #RegisterVariable
  instanceVariableNames: 'register spilled damaged liveRanges weight '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!RegisterVariable class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!RegisterVariable methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize 
  spilled _ false.
  damaged _ true.
  weight _ 1! !

!RegisterVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
register
  ^ register! !

!RegisterVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
register: aRegister
  register _ aRegister! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
usesFixedRegister
  ^ false! !

!RegisterVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
spilled
  ^ spilled! !

!RegisterVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
spilled: aBoolean
  spilled _ aBoolean! !

!RegisterVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
damaged
  ^ damaged! !

!RegisterVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
damaged: aBoolean
  damaged _ aBoolean! !

!RegisterVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
liveRanges
  ^ liveRanges! !

!RegisterVariable methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
locationAt: anInteger
  ^ RegisterVariableLocation new
      variable: self;
      register: 
        ((self liveAt: anInteger) 
          ifTrue: [register]
          ifFalse: []);
      damaged: damaged! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
holeAt: anInteger
  ^ self register notNil
      and: [liveRanges first start >= anInteger]! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
holeIncluding: aRegisterVariable
  ^ self holeAt: aRegisterVariable liveRanges last end! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
liveAt: anInteger
  ^ self register notNil
      and: [spilled not]
      and: [liveRanges first start <= anInteger]! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
reloadAt: anInteger
  ^ self register notNil
      and: [spilled]
      and: [liveRanges first start <= anInteger]! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
weight
  ^ (end - start) / weight! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
weight: anInstruction
  | newWeight |
  newWeight _ 1.
  anInstruction basicBlock region loop
    ifNotNilDo:
      [:loop |
        newWeight _ loop depth + 1].
  weight _ weight max: newWeight! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
useLiveRangeAt: anInteger
  liveRanges ifNil: [liveRanges _ OrderedCollection new].
  (liveRanges isEmpty or: [liveRanges first start notNil])
    ifTrue:
      [liveRanges addFirst: (LiveRange new end: anInteger)]! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
defineLiveRangeAt: anInteger
  self useLiveRangeAt: anInteger.
  liveRanges first start: anInteger! !

!RegisterVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
removeLiveRangeAt: anInteger
  liveRanges first end <= anInteger
    ifTrue:
      [liveRanges removeFirst]! !

RegisterVariable subclass: #LocalVariable
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!LocalVariable methodsFor: 'SSA translation' stamp: 'lrs 05/26/2002 11:14'!
mayLinkUsesToDefinitions
  ^ true! !

RegisterVariable subclass: #InputOutputVariable
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

!InputOutputVariable methodsFor: 'register allocation' stamp: 'lrs 05/26/2002 11:14'!
usesFixedRegister
  ^ self register notNil! !

InputOutputVariable subclass: #InputVariable
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

InputOutputVariable subclass: #OutputVariable
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Storage'!

Object subclass: #ListElement
  instanceVariableNames: 'nextElement previousElement'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Support'!

!ListElement methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
nextElement
  ^ nextElement! !

!ListElement methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
nextElement: aListElement
  nextElement _ aListElement! !

!ListElement methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
previousElement
  ^ previousElement! !

!ListElement methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
previousElement: aListElement
  previousElement _ aListElement! !

!ListElement methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
addBefore: aListElement
  previousElement _ aListElement previousElement.
  nextElement _ aListElement.
  previousElement nextElement: self.
  nextElement previousElement: self! !

!ListElement methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
addAfter: aListElement
  self addBefore: aListElement nextElement! !

!ListElement methodsFor: 'removing' stamp: 'lrs 05/26/2002 11:14'!
remove
  nextElement previousElement: previousElement.
  previousElement nextElement: nextElement! !

ListElement subclass: #List
  instanceVariableNames: 'size '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Support'!

!List class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!List methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  self clear! !

!List methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
size
  ^ size! !

!List methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
first
  ^ self nextElement! !

!List methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
last
  ^ self previousElement! !

!List methodsFor: 'removing' stamp: 'lrs 05/26/2002 11:14'!
clear
  size _ 0.
  self nextElement: self.
  self previousElement: self! !

!List methodsFor: 'testing' stamp: 'lrs 05/26/2002 11:14'!
isEmpty
  ^ size = 0! !

!List methodsFor: 'testing' stamp: 'lrs 05/26/2002 11:14'!
notEmpty
  ^ size ~= 0! !

!List methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
addFirst: aListElement
  ^ self add: aListElement before: self first! !

!List methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
addLast: aListElement
  ^ self add: aListElement before: self! !

!List methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
add: newListElement before: oldListElement
  size _ size + 1.
  ^ newListElement addBefore: oldListElement! !

!List methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
add: newListElement after: oldListElement
  ^ self add: aListElement before: oldListElement nextElement! !

!List methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
add: aListElement
  ^ self addLast: aListElement! !

!List methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
addAll: aCollection
  aCollection
    do:
      [:element |
        self add: element].
  ^ aCollection! !

!List methodsFor: 'removing' stamp: 'lrs 05/26/2002 11:14'!
remove: aListElement
  size _ size - 1.
  ^ aListElement remove! !

!List methodsFor: 'removing' stamp: 'lrs 05/26/2002 11:14'!
removeFirst
  ^ self remove: self first! !

!List methodsFor: 'removing' stamp: 'lrs 05/26/2002 11:14'!
removeLast
  ^ self remove: self last! !

!List methodsFor: 'removing' stamp: 'lrs 05/26/2002 11:14'!
removeAll: aCollection
  aCollection
    do:
      [:element |
        self remove: element].
  ^ aCollection! !

!List methodsFor: 'enumerating' stamp: 'lrs 05/26/2002 11:14'!
do: aBlock
  | element |
  element _ self first.
  [element == self]
    whileFalse:
      [element _ element nextElement.
        aBlock value: element previousElement]! !

!List methodsFor: 'enumerating' stamp: 'lrs 05/26/2002 11:14'!
reverseDo: aBlock
  | element |
  element _ self last.
  [element = self]
    whileFalse:
      [element _ element previousElement.
        aBlock value: element nextElement]! !

!List methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
concatenateFirst: aList
  aList isEmpty
    ifTrue:
      [^ self].
  size _ size + aList size.
  self first previousElement: aList last.
  aList last nextElement: self first.
  self nextElement: aList first.
  self first previousElement: self.
  aList clear! !

!List methodsFor: 'adding' stamp: 'lrs 05/26/2002 11:14'!
concatenateLast: aList
  aList isEmpty
    ifTrue:
      [^ self].
  size _ size + aList size.
  self last nextElement: aList first.
  aList first previousElement: self last.
  self previousElement: aList last.
  self last nextElement: self.
  aList clear! !

PluggableSet subclass: #ExpressionSet
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Support'!

!ExpressionSet class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!ExpressionSet class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new: anInteger
  ^ (super new: anInteger) initialize! !

!ExpressionSet methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  self
    hashBlock:
      [:instruction |
        instruction expressionHash].
  self
    equalBlock:
      [:x :y |
        x expressionCompare: y]! !

PluggableDictionary subclass: #ExpressionDictionary
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Support'!

!ExpressionDictionary class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!ExpressionDictionary class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new: anInteger
  ^ (super new: anInteger) initialize! !

!ExpressionDictionary methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  self
    hashBlock:
      [:instruction |
        instruction expressionHash].
  self
    equalBlock:
      [:x :y |
        x expressionCompare: y]! !

PluggableScopedDictionary subclass: #ScopedExpressionDictionary
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Support'!

!ScopedExpressionDictionary class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!ScopedExpressionDictionary class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new: anInteger
  ^ (super new: anInteger) initialize! !

!ScopedExpressionDictionary methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  self
    hashBlock:
      [:instruction |
        instruction expressionHash].
  self
    equalBlock:
      [:x :y |
        x expressionCompare: y]! !

Association subclass: #ScopedDictionaryEntry
  instanceVariableNames: 'nextEntry'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Support'!

!ScopedDictionaryEntry methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
nextEntry
  ^ nextEntry! !

!ScopedDictionaryEntry methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
nextEntry: aScopedDictionaryEntry
  nextEntry _ aScopedDictionaryEntry! !

!ScopedDictionaryEntry methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
key: keyObject value: valueObject nextEntry: aScopedDictionaryEntry
  self key: keyObject value: valueObject.
  nextEntry _ aScopedDictionaryEntry! !

Object subclass: #ScopedDictionary
  instanceVariableNames: 'scopes '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Support'!

!ScopedDictionary class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize: 16! !

!ScopedDictionary class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new: anInteger
  ^ super new initialize: anInteger! !

!ScopedDictionary methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize: anInteger
  scopes _ OrderedCollection with: (Array new: anInteger)! !

!ScopedDictionary methodsFor: 'scoping' stamp: 'lrs 05/26/2002 11:14'!
pushScope
  (scopes last isKindOf: Array)
    ifTrue:
      [scopes addLast: 1]
    ifFalse:
      [scopes last: scopes last + 1]! !

!ScopedDictionary methodsFor: 'scoping' stamp: 'lrs 05/26/2002 11:14'!
popScope
  | top |
  top _ scopes last.
  (top isKindOf: Array)
    ifTrue:
      [scopes removeLast]
    ifFalse:
      [top = 1
        ifTrue: [scopes removeLast]
        ifFalse: [scopes last: top - 1]]! !

!ScopedDictionary methodsFor: 'private' stamp: 'lrs 05/26/2002 11:14'!
errorKeyNotFound
  self error: 'key not found'! !

!ScopedDictionary methodsFor: 'private' stamp: 'lrs 05/26/2002 11:14'!
topScope
  | top |
  top _ scopes last.
  (top isKindOf: Array)
    ifFalse:
      [top = 1
        ifTrue:
          [top _ (scopes at: scopes size - 1) copy.
            scopes last: top]
        ifFalse:
          [scopes last: top - 1.
            top _ (scopes at: scopes size - 1) copy.
            scopes addLast: top]].
  ^ top! !

!ScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
at: anObject ifPresent: presentBlock ifAbsent: absentBlock
  | top |
  top _ scopes last.
  (top isKindOf: Array)
    ifFalse: [top _ scopes at: scopes size - 1].
  (top at: (anObject hash \\ top size) + 1)
    ifNotNilDo:
      [:entry |
        [entry isNotNil]
          whileTrue:
            [entry key = anObject
              ifTrue: 
                [^ presentBlock value: entry value].
              entry _ entry nextEntry]].
  ^ absentBlock value! !

!ScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
at: anObject ifAbsent: aBlock
  ^ self at: anObject ifPresent: [:value | value] ifAbsent: aBlock! !

!ScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
at: anObject ifPresent: aBlock
  ^ self at: anObject ifPresent: aBlock ifAbsent: []! !

!ScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
at: anObject
  ^ self at: anObject ifAbsent: [self errorKeyNotFound]! !

!ScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
at: keyObject put: valueObject
  | top hash |
  top _ self topScope.
  hash _ (keyObject hash \\ top size) + 1.
  (top at: hash)
    ifNotNilDo:
      [:entry |
        [entry isNotNil]
          whileTrue:
            [entry key = keyObject
              ifTrue:
                [entry value: valueObject.
                  ^ valueObject].
              entry _ entry nextEntry]].
  top 
    at: hash 
    put: 
      (ScopedDictionaryEntry new 
        key: keyObject
        value: valueObject
        nextEntry: (top at: hash)).
  ^ valueObject! !

ScopedDictionary subclass: #PluggableScopedDictionary
  instanceVariableNames: 'hashBlock equalBlock '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Support'!

!PluggableScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
hashBlock
  ^ hashBlock! !

!PluggableScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
hashBlock: aBlock
  hashBlock _ aBlock! !

!PluggableScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
equalBlock
  ^ equalBlock! !

!PluggableScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
equalBlock: aBlock
  equalBlock _ aBlock! !

!PluggableScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
at: anObject ifPresent: presentBlock ifAbsent: absentBlock
  | top hash |
  top _ scopes last.
  (top isKindOf: Array)
    ifFalse: [top _ scopes at: scopes size - 1].
  hashBlock
    ifNil:
      [hash _ anObject hash]
    ifNotNil:
      [hash _ hashBlock value: anObject].
  (top at: (hash \\ top size) + 1)
    ifNotNilDo:
      [:entry |
        [entry isNotNil]
          whileTrue:
            [(equalBlock
              ifNil:
                [entry key = anObject]
              ifNotNil:
                [equalBlock value: entry key value: keyObject])
              ifTrue:
                [^ presentBlock value: entry value].
              entry _ entry nextEntry]].
  ^ absentBlock value! !

!PluggableScopedDictionary methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
at: keyObject put: valueObject
  | top hash |
  top _ self topScope.
  hashBlock
    ifNil:
      [hash _ anObject hash]
    ifNotNil:
      [hash _ hashBlock value: keyObject].
  hash _ (hash \\ top size) + 1.
  (top at: hash)
    ifNotNilDo:
      [:entry |
        [entry isNotNil]
          whileTrue:
            [(equalBlock
              ifNil:
                [entry key = keyObject]
              ifNotNil:
                [equalBlock value: entry key value: keyObject])
              ifTrue:
                [entry value: valueObject.
                  ^ valueObject].
              entry _ entry nextEntry]].
  top
    at: hash
    put:
      (ScopedDictionaryEntry new
        key: keyObject
        value: valueObject
        nextEntry: (top at: hash)).
  ^ valueObject! !

Object subclass: #RedundancyClass
  instanceVariableNames: 'value definingOccurrence '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!RedundancyClass methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
value
  ^ value! !

!RedundancyClass methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
value: anInstruction
  value _ anInstruction! !

!RedundancyClass methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
definingOccurrence
  ^ definingOccurrence! !

!RedundancyClass methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
definingOccurrence: aRedundancyGraphNode
  definingOccurrence _ aRedundancyGraphNode! !

Object subclass: #RedundancyGraphNode
  instanceVariableNames: 'redundancyGraph redundancyClass successors '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!RedundancyGraphNode class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
new
  ^ super new initialize! !

!RedundancyGraphNode methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  successors _ OrderedCollection new! !

!RedundancyGraphNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
redundancyGraph
  ^ redundancyGraph! !

!RedundancyGraphNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
redundancyGraph: aRedundancyGraph
  redundancyGraph _ aRedundancyGraph! !

!RedundancyGraphNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
redundancyClass
  ^ redundancyClass! !

!RedundancyGraphNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
redundancyClass: aRedundancyClass
  redundancyClass _ aRedundancyClass! !

!RedundancyGraphNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
successors
  ^ successors! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
downSafe
  ^ true! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
canBeAvailable
  ^ true! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
latest
  ^ false! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
needsRepair
  ^ false! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
needsRepair: aBoolean
! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
accumulateInjury
  ^ false! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeDownSafety
! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeCanBeAvailable
! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeLatest
! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeNeedsRepair
! !

!RedundancyGraphNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeRedundancyClass: aRedundancyClass
  redundancyClass _ aRedundancyClass.
  ^ aRedundancyClass! !

!RedundancyGraphNode methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
eliminateRedundancies
! !

!RedundancyGraphNode methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
receiveFlow: aRedundancyGraphNode
! !

RedundancyGraphNode subclass: #RedundancyGraphEntry
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

RedundancyGraphNode subclass: #RedundancyGraphExit
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!RedundancyGraphExit methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
downSafe
  ^ false! !

!RedundancyGraphExit methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
canBeAvailable
  ^ false! !

RedundancyGraphNode subclass: #OccurrenceNode
  instanceVariableNames: 'instruction predecessor '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!OccurrenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
instruction
  ^ instruction! !

!OccurrenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
instruction: anInstruction
  instruction _ anInstruction! !

!OccurrenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
predecessor
  ^ predecessor! !

!OccurrenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
predecessor: aRedundancyGraphNode
  predecessor _ aRedundancyGraphNode! !

OccurrenceNode subclass: #ComputationOccurrenceNode
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!ComputationOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
latest
  ^ true! !

!ComputationOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeRedundancyClass: aRedundancyClass
  self
    redundancyClass:
      ((aRedundancyClass isNil)
        ifTrue:
          [RedundancyClass new 
            value: 
              (self redundancyGraph substitutions
                at: self instruction
                ifAbsent: [self instruction])
            definingOccurrence: self]
        ifFalse:
          [aRedundancyClass]).
  ^ self redundancyClass! !

!ComputationOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeNeedsRepair
  | predecessor latestRepair |
  predecessor _ self predecessor.
  latestRepair _ nil.
  [((predecessor isKindOf: RedefinitionOccurrenceNode)
    and: [self redundancyGraph template isInjuredBy: predecessor instruction])
    or: [predecessor isKindOf: TestOccurrenceNode]]
    whileTrue:
      [((predecessor isKindOf: RedefinitionOccurenceNode)
         and: [self redundancyGraph template canAccumulateInjury: predecessor instruction])
        ifTrue:
          [(latestRepair notNil 
            and:
              [latestRepair instruction outputOperand == 
                predecessor instruction outputOperand])
            ifTrue:
              [predecessor accumulateInjury: true]
            ifFalse:
              [predecessor needsRepair: true.
                latestRepair _ predecessor]]
        ifFalse:
          [predecessor needsRepair: true.
            latestRepair _ nil].
        predecessor _ predecessor predecessor]! !

!ComputationOccurrenceNode methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
eliminateRedundancies
  | redundancyClass move |
  redundancyClass _ self predecessor redundancyClass.
  redundancyClass ifNil: [redundancyClass _ self redundancyClass].
  redundancyClass definingOccurrence == self
    ifFalse:
      [redundancyClass value outputOperands > 0
        ifTrue:
          [self redundancyGraph substitutions 
            at: self instruction
            ifAbsentPut: 
              [redundancyClass value outputOperand == 
                self redundancyGraph temporaryVariable
                ifFalse:
                  [move _ MoveInstruction new
                            operands:
                              (Array
                                with: self redundancyGraph temporaryVariable
                                with: redundancyClass value).
                    (self redundancyGraph assignments
                      at: move outputOperand
                      ifAbsentPut: [OrderedCollection new])
                      addLast: move.  
                    redundancyClass value basicBlock add: move.
                    redundancyClass value: move].
                redundancyClass value]]
        ifFalse:
          [self instruction basicBlock remove: self instruction]]! !

OccurrenceNode subclass: #TestOccurrenceNode
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!TestOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
downSafe
  ^ self successors allSatisfy: [:successor | successor downSafe]! !

!TestOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
canBeAvailable
  ^ self predecessor canBeAvailable! !

!TestOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
latest
  ^ self predessor latest! !

!TestOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
redundancyClass
  ^ self predecessor redundancyClass! !

!TestOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeRedundancyClass: aRedundancyClass
  redundancyClass _ aRedundancyClass.
  ^ aRedundancyClass! !

!TestOccurrenceNode methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
eliminateRedundancies
  (self redundancyClass notNil 
    and:
      [self redundancyClass value notNil])
    ifTrue:
      [self redundancyGraph template
        replaceTest: self instruction
        fromValue: self redundancyClass value
        in: self redundancyGraph]! !

OccurrenceNode subclass: #RedefinitionOccurrenceNode
  instanceVariableNames: 'needsRepair accumulateInjury '
  classVariableNames: '' 
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!RedefinitionOccurrenceNode methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  super initialize.
  needsRepair _ false.
  accumulateInjury _ false!   !

!RedefinitionOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
downSafe
  ^ false! !

!RedefinitionOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
canBeAvailable
  ^ false! !

!RedefinitionOccurrenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
needsRepair
  ^ needsRepair! !

!RedefinitionOccurrenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
needsRepair: aBoolean
  needsRepair _ aBoolean! !

!RedefinitionOccurrenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
accumulateInjury
  ^ accumulateInjury! !

!RedefinitionOccurrenceNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
accumulateInjury: aBoolean
  accumulateInjury _ aBoolean! !

!RedefinitionOccurrenceNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeRedundancyClass: aRedundancyClass
  ^ nil! !

!RedefinitionOccurrenceNode methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
eliminateRedundancies
  | increment predecessor |
  self redundancyGraph namespace 
    at: self instruction outputOperand 
    put: self instruction.
  needsRepair
    ifTrue:
      [predecessor _ self predecessor.
        [predecessor accumulateInjury]
          whileTrue:
            [predecessor _ predecessor predecessor].
        increment _ self redundancyGraph template 
                      repairInjury: self instruction
                      fromValue: predecessor redundancyClass value
                      in: self redundancyGraph.
        predecessor _ self predecessor.
        [predecessor accumulateInjury]
          whileTrue:
            [self redundancyGraph template
              accumulateInjury: predecessor instruction
              into: increment.
              predecessor _ predecessor predecessor].
        self 
          redundancyClass: 
            (RedundancyClass new 
              value: increment
              definingOccurrence: self)]! !

Object subclass: #FactoredRedundancyFlow
  instanceVariableNames: 'basicBlock predecessor '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!FactoredRedundancyFlow methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock
  ^ basicBlock! !

!FactoredRedundancyFlow methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock: aBasicBlock
  basicBlock _ aBasicBlock! !

!FactoredRedundancyFlow methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
predecessor
  ^ predecessor! !

!FactoredRedundancyFlow methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
predecessor: aRedundancyGraphNode
  predecessor _ aRedundancyGraphNode! !

RedundancyGraphNode subclass: #FactoredRedundancyNode
  instanceVariableNames: 'basicBlock flows merges downSafe canBeAvailable latest '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!FactoredRedundancyNode methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
initialize
  super initialize.
  merges _ Set new.
  downSafe _ true.
  canBeAvailable _ true.
  latest _ true! !

!FactoredRedundancyNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock
  ^ basicBlock! !

!FactoredRedundancyNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
basicBlock: aBasicBlock
  | flows index |
  flows _ Array new: aBasicBlock countPredecessors.
  index _ 1.
  aBasicBlock
    doPredecessors:
      [:predecessor |
        flows at: index put: (FactoredRedundancyFlow new basicBlock: predecessor).
        index _ index + 1].
  basicBlock _ aBasicBlock! !

!FactoredRedundancyNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
flows
  ^ flows! !

!FactoredRedundancyNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
merges
  ^ merges! !

!FactoredRedundancyNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
downSafe
  ^ downSafe! !

!FactoredRedundancyNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
canBeAvailable
  ^ canBeAvailable! !

!FactoredRedundancyNode methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
latest
  ^ latest! !

!FactoredRedundancyNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeDownSafety
  downSafe _ self successors allSatisfy: [:successor | successor downSafe]! !

!FactoredRedundancyNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeCanBeAvailable
  downSafe
    ifFalse:
      [canBeAvailable _ flows 
                          allSatisfy: 
                            [:flow | flow predecessor canBeAvailable]]! !

!FactoredRedundancyNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeLatest
  canBeAvailable
    ifTrue:
      [latest _ flows anySatisfy: [:flow | flow predecessor latest]]! !

!FactoredRedundancyNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeRedundancyClass: aRedundancyClass
  canBeAvailable & latest
    ifTrue:
      [self
        redundancyClass:
          ((flows 
            allSatisfy: 
              [:flow | flow predecessor redundancyClass == aRedundancyClass])
            ifTrue: [aRedundancyClass]
            ifFalse: 
              [RedundancyClass new
                value:
                  (self redundancyGraph template outputOperands > 0
                    ifTrue: [self redundancyGraph insertMergeAt: self basicBlock]);
                definingOccurrence: self])].
  ^ self redundancyClass! !

!FactoredRedundancyNode methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeNeedsRepair
  | predecessor latestRepair |
  canBeAvailable & latest
    ifFalse:
      [^ self].
  flows
    do:
      [:flow |
         predecessor _ flow predecessor. 
         latestRepair _ nil.
         [((predecessor isKindOf: RedefinitionOccurrenceNode)
            and: 
              [self redundancyGraph template 
                isInjuredBy: 
                  predecessor instruction])
            or: [predecessor isKindOf: TestOccurrenceNode]]
           whileTrue:
             [((predecessor isKindOf: RedefeinitionOccurrenceNode)
               and: 
                 [self redundancyGraph template 
                   canAccumulateInjury: 
                     predecessor instruction])
               ifTrue:
                  [(latestRepair notNil 
                    and:
                      [latestRepair instruction outputOperand ==
                        predecessor instruction outputOperand])
                    ifTrue:
                      [predecessor accumulateInjury: true]
                    ifFalse:
                      [predecessor needsRepair: true.
                        latestRepair _ predecessor]]
               ifFalse:
                 [predecessor needsRepair: true.
                   latestRepair _ nil].
               predecessor _ predecessor predecessor]]! !

!FactoredRedundancyNode methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
eliminateRedundancies
  merges
    do:
     [:merge |
       self redundancyGraph namespace at: merge outputOperand put: merge]! !

!FactoredRedundancyNode methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
receiveFlow: aRedundancyGraphNode
  | index value |
  (self redundancyClass notNil
    and: [self redundancyClass definingOccurrence == self])
    ifTrue:
      [index _ flows findFirst: [:flow | flow predecessor == aRedundancyGraphNode].
        value _ aRedundancyGraphNode redundancyClass
                  ifNotNil:
                    [aRedundancyGraphNode redundancyClass]
                  ifNil:
                    [self redundancyGraph
                      insertComputationAt: (flows at: index) basicBlock].
        self redundancyClass value
          ifNotNil:
            [self redundancyClass value operands 
              at: index + 1 
              put: value]]! !

Object subclass: #RedundancyGraph
  instanceVariableNames: 'function template substitutions namespace assignments merges tests expressions entry exit temporaryVariable'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function: aFunction
  function _ aFunction! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function
  ^ function! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
template
  ^ template! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
substitutions
  ^ substitutions! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
substitutions: aDictionary
  substitutions _ aDictionary! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
namespace
  ^ namespace! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
assignments
  ^ assignments! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
assignments: aDictionary
  assignments _ aDictionary! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
merges
  ^ merges! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
merges: aDictionary
  merges _ aDictionary! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
tests
  ^ tests! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
tests: aDictionary
  tests _ aDictionary! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
expressions
  ^ expressions! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
expressions: anOrderedCollection
  expressions _ anOrderedCollection! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
nodes
  ^ nodes! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
entry
  ^ entry! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
exit
  ^ exit! !

!RedundancyGraph methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
temporaryVariable
  temporaryVariable
    ifNil:
      [temporaryVariable _ function
                             allocateLocalVariable:
                               template outputOperand storageType].

  ^ temporaryVariable! !

!RedundancyGraph methodsFor: 'private' stamp: 'lrs 05/26/2002 11:14'!
buildNodes
  | factors predecessors occurrences predecessor operands instruction index |
  factors _ Dictionary new: 64.
  index _ 1.
  [index <= expressions size]
    whileTrue:
      [instruction _ expressions at: index.
        instruction basicBlock
          doIteratedDominanceFrontier:
            [:frontier |
              factors
                at: frontier
                ifAbsentPut:
                  [FactoredRedundancyNode new
                    redundancyGraph: self;
                    basicBlock: frontier]].
        index _ index + 1.
        [index <= expressions size
          and:
            [(expressions at: index) basicBlock = instruction basicBlock]]
          whileTrue:
            [index _ index + 1]].
  template
    doInputOperands:
      [:operand |
        merges
          at: operand outputOperand
          ifPresent:
            [:instructions |
              instructions
                do:
                  [:merge |
                    (factors
                      at: merge basicBlock
                      ifAbsentPut:
                        [FactoredRedundancyNode new
                          redundancyGraph: self;
                          basicBlock: merge basicBlock])
                      merges add: merge]]]
    ifKindOf: Instruction.
  predecessors _ OrderedCollection new.
  occurrences _ OrderedCollection new.
  operands _ Set new.
  template
    doInputOperands:
      [:operand |
        operands add: operand outputOperand]
    ifKindOf: Instruction.
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        predecessor _ nil.
        factors
          at: basicBlock
          ifPresent:
            [:factor |
              nodes add: factor.
              predecessor _ factor]
          ifAbsent:
            [[predecessors notEmpty
              and: [(predecessors last basicBlock dominates: basicBlock) not]]
              whileTrue:
                [predecessors removeLast].
              predecessors isEmpty
                ifTrue: [predecessor _ entry]
                ifFalse: [predecessor _ predecessors last]].
        occurrences reset.
        operands
          do:
            [:operand |
              assignments
                at: operand
                ifPresent:
                  [:instructions |
                    index _ 1.
                    [index <= instructions size
                      and:
                        [instruction _ instructions at: index.
                          index _ index + 1.
                          instruction basicBlock == basicBlock]]
                      whileTrue:
                        [occurrences 
                          add: 
                            (RedefinitionOccurrenceNode new
                              redundancyGraph: self;
                              instruction: instruction)]].
              [tests notNil]
                ifTrue:
                  [tests
                    at: operand
                    ifPresent:
                      [:instructions |
                        index _ 1.
                        [index <= instructions size
                          and:
                            [instruction _ instructions at: index.
                              index _ index + 1.
                              instruction basicBlock == basicBlock]]
                          whileTrue:
                            [occurrences
                              add: 
                                (RedefinitionOccurrenceNode new
                                  redundancyGraph: self;
                                  instruction: instruction)]]]].
        index _ 1.
        [index <= expressions size
          and:
            [instruction _ expressions at: index.
              index _ index + 1.
              instruction basicBlock == basicBlock]]
          whileTrue:
            [occurrences 
              add: 
                (ComputationOccurrenceNode new
                  redundancyGraph: self;
                  instruction: instruction)].
        occurrences notEmpty
          ifTrue:
            [(occurrences
              asSortedCollection:
                [:x :y |
                  (x instruction == y instruction
                    and: [x isKindOf: ComputationOccurrenceNode])
                    or: [x instruction dominates: y instruction]])
              do:
                [:occurrence |
                  occurrence predecessor: predecessor.
                  predecessor successors add: occurrence.
                  nodes add: occurrence.
                  predecessor _ occurrence].
              predecessors add: predecessor].
        [basicBlock exits isEmpty]
          ifTrue:
            [predecessor successors add: exit].
        basicBlock
          doSuccessors:
            [:successor |
              factors
                at: successor
                ifPresent:
                  [:factor |
                    (factor flows detect: [:flow | flow basicBlock == basicBlock])
                      predecessor: predecessor]]]! !

!RedundancyGraph methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeDownSafety
  nodes
    reverseDo:
      [:node |
        node computeDownSafety]! !

!RedundancyGraph methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeCanBeAvailable
  nodes
    do:
      [:node |
        node computeCanBeAvailable]! !

!RedundancyGraph methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeLatest
  nodes
    do:
      [:node |
        node computeLatest]! !

!RedundancyGraph methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeRedundancyClass
  nodes
    inject: nil
    into:
      [:redundancyClass :node |
        node computeRedundancyClass: redundancyClass]! !

!RedundancyGraph methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeNeedsRepair
  nodes
    do:
      [:node |
        computeNeedsRepair]! !

!RedundancyGraph methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
insertMergeAt: aBasicBlock
  | merge |
  merge _ MergeInstruction new
            operands:
              (Array new: aBasicBlock countPredecessors + 1).
  merge outputOperand: self temporaryVariable.
  (merges 
    at: merge outputOperand
    ifAbsentPut: [OrderedCollection new])
    addLast: merge.
  aBasicBlock addFirst: merge.
  ^ merge! !

!RedundancyGraph methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
insertComputationAt: aBasicBlock
  | computation |
  computation _ template class new 
                  operands: (template operands copy).
  template outputOperands > 0
    ifTrue:
      [computation outputOperand: self temporaryVariable.
        (assignments
          at: computation outputOperand
          ifAbsentPut: [OrderedCollection new])
          addLast: computation].
  template
    doInputOperandsWithIndex:
      [:operand :index |
        (operand isKindOf: Instruction)
          ifTrue:
            [computation operands
              at: index
              put: (namespace at: operand outputOperand)]].
  aBasicBlock add: computation.
  ^ computation! !

!RedundancyGraph methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
eliminateRedundancies
  | scopeOwner |
  nodes _ OrderedCollection new: 2 * expressionDictionary size.
  entry _ RedundancyGraphEntry new.
  exit _ RedundancyGraphExit new.
  self buildNodes.
  self computeDownSafety.
  self computeCanBeAvailable.
  self computeLatest.
  self computeRedundancyClass.
  template strengthReductionCandidate
    ifTrue:
      [self computeNeedsRepair].
  namespace _ ScopedDictionary new.
  namespace pushScope.
  scopeOwner _ OrderedCollection new: 16.
  nodes 
    do:
      [:node |
        [scopeOwner last basicBlock dominates: node instruction basicBlock]
          whileFalse:
            [namespace popScope. 
              scopeOwner removeLast].
        ((node predecessor isKindOf: FactoredRedundancyNode)
          and:
            [node predecessor successors size > 1])
          ifTrue:
            [namespace pushScope.
              scopeOwner addLast: node instruction basicBlock].
        node eliminateRedundancies.
        node successors
          do:
            [:successor |
              successor receiveFlow: node]]!  !

Object subclass: #PartialRedundancyEliminator
  instanceVariableNames: 'function assignments merges tests expressions ordering substitutions '
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Redundancy Elimination'!

!PartialRedundancyEliminator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function
  ^ function! !

!PartialRedundancyEliminator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
function: aFunction
  function _ aFunction! !

!PartialRedundancyEliminator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
assignments
  ^ assignments! !

!PartialRedundancyEliminator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
merges
  ^ merges! !

!PartialRedundancyEliminator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
tests
  ^ tests! !

!PartialRedundancyEliminator methodsFor: 'accessing' stamp: 'lrs 05/26/2002 11:14'!
substitutions
  ^ substitutions! !

!PartialRedundancyEliminator methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
collectExpressions
  | depths |
  assignments _ Dictionary new.
  merges _ Dictionary new.
  tests _ Dictionary new.
  expressions _ ExpressionDictionary new.
  depths _ ExpressionDictionary new.
  ordering _ OrderedCollection new.
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock | 
        basicBlock
          do:
            [:instruction |
              instruction mayBeRedundant
                ifTrue:
                  [depths
                    at: instruction
                    put:
                      ((instruction expressionDepth: depths)
                        max:
                          (depths
                            at: instruction
                            ifPresent: [:depth | depth]
                            ifAbsent: [0])).
                    (expressions
                      at: instruction
                      ifAbsentPut: [Orderedcollection new])
                      addLast: instruction].
              (instruction isKindOf: MergeInstruction)
                ifTrue:
                  [(merges
                    at: instruction outputOperand
                    ifAbsentPut: [OrderedCollection new])
                    addLast: instruction].
              instruction mayBeReplaceableTest
                ifTrue:
                  [instruction
                    doInputOperands:
                      [:operand |
                        (tests
                          at: operand outputOperand
                          ifAbsentPut: [OrderedCollection new])
                          addLast: instruction]
                    if: [:operand | operand mayLinkUsesToDefinitions]].
              instruction isAssignment
                ifTrue:
                  [instruction
                    doOutputOperands:
                      [:operand |
                        (assignments
                          at: operand
                          ifAbsentPut: [OrderedCollection new])
                          addLast: instruction]
                    if: [:operand | operand mayLinkUsesToDefinitions]]]].
  depths
    keysAndValuesDo:
      [:expression :depth |
        depth > ordering size
          ifTrue:
            [(depth - ordering size) 
              timesRepeat:
                [ordering addLast: OrderedCollection new]].
        (ordering at: depth) add: (expressions at: expression)]! !

!PartialRedundancyEliminator methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
eliminatePartialRedundancies
  | template currentExpressions newExpressions |
  self collectExpressions.
  substitutions _ Dictionary new.
  ordering
    do:
      [:stage |
        [stage notEmpty]
          whileTrue:
            [currentExpressions _ stage removeFirst.
              currentExpressions size > 1
                ifTrue:
                  [template _ currentExpressions first copy.
                    expressions
                      at: template
                      put: (expressions removeKey: template).
                    currentExpressions
                      do:
                        [:instruction |
                          (instruction substituteOperands: substitutions) > 0
                            ifTrue:
                              [newExpressions _ expressions 
                                                  at: instruction
                                                  ifAbsentPut: 
                                                    [stage 
                                                      addLast: 
                                                        OrderedCollection new].
                                currentExpressions == newExpressions
                                  ifFalse:
                                    [newExpressions add: instruction]]].
                    (RedundancyGraph new
                      function: function;
                      template: template;
                      substitutions: substitutions;
                      expressions: currentExpressions;
                      assignments: assignments;
                      merges: merges;
                      tests:
                        (template strengthReductionCandidate ifTrue: [tests]))
                      eliminateRedundancies]]]! !

Object subclass: #RegisterAllocator
  instanceVariableNames: 'function currentTime allocatedVariables freeRegisters calleeSaveRegisters modifiedRegisters'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Squeampiler-Register Allocation'!

!RegisterAllocator class methodsFor: 'instance creation' stamp: 'lrs 05/26/2002 11:14'!
for: aFunction
  ^ super new for: aFunction! !

!RegisterAllocator methodsFor: 'initializing' stamp: 'lrs 05/26/2002 11:14'!
for: aFunction
  function _ aFunction! !

!RegisterAllocator methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
allocateRegisters
  | ordering |
  self computeLiveness.
  allocatedVariables _ Set new.
  currentTime _ 0.
  ordering _ OrderedCollection new.
  function exit
    doPostDominatorTreeBeforeDescent:
      [:basicBlock |
        ordering addFirst: basicBlock.
        self computeLiveRangesFor: basicBlock].
  freeRegisters _ aFunction compilationUnit architecture callerSaveRegisters copy.
  calleeSaveRegisters _ aFunction compilationUnit architecture calleeSaveRegisters copy.
  modifiedRegisters _ Set new.
  allocatedVariables _ Set new.
  freeRegisters
    do:
      [:register |
        register useCount: 0].
  calleeSaveRegisters
    do:
      [:register |
        register useCount: 0].
  function inputVariables
    do:
      [:inputVariable |
        allocatedVariables add: inputVariable.
        inputVariable register
          ifNotNil:
            [inputVariable register useCount: 1.
              freeRegisters remove: inputVariable register]
          ifNil:
            [inputVariable spilled: true.
              inputVariable damaged: false]].
  ordering
    do:
      [:basicBlock |
        self allocateRegistersFor: basicBlock].
  ordering
    do:
      [:basicBlock |
        self resolveAllocationConflictsFor: basicBlock].
  function allocatedRegisters: modifiedRegisters! !

!RegisterAllocator methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
resolveAllocationConflictsFor: aBasicBlock
  | used spills reloads copies remap workList copy source temporary |
  used _ Set new.
  spills _ OrderedCollection new.
  reloads _ OrderedCollection new.
  copies _ OrderedCollection new.
  remap _ Dictionary new.
  workList _ OrderedCollection new.
  aBasicBlock
    doSuccessors:
      [:successor |
        successor locationIn
          doKeysAndValues:
            [:registerVariable :destination |
              source _ aBasicBlock locationOut at: registerVariable.
              (destination register isNil
                 or: [source register isNil]
                 or: [destination damaged]
                 or: [source damaged not])
                ifFalse:
                  [copy _ SpillInstruction new
                            operands:
                              (Array
                                with: registerVariable
                                with: source register).
                    source damaged: false.
                    spills add: copy].
              destination register == source register
                ifFalse:
                  [destination register
                    ifNotNil:
                      [source register
                        ifNotNil:
                          [copy _ Array
                                    with: destination register
                                    with: source.
                            copies add: copy.
                            used add: source register]
                        ifNil:
                          [copy _ ReloadInstructions new
                                    operands:
                                      (Array
                                        with: destination register
                                        with: registerVariable).
                            reloads add: copy]]
                    ifNil:
                      [copy _ SpillInstruction new
                                operands:
                                  (Array
                                    with: registerVariable
                                    with: source register).
                        spills add: copy]]]].
  spills
    do:
      [:spill |
        aBasicBlock add: spill].
  copies
    do:
      [:nextCopy |
        (used includes: (copy at: 1))
          ifFalse:
            [workList add: nextCopy.
              copies remove: nextCopy]].
  [workList notEmpty or: [copies notEmpty]]
    whileTrue:
      [[workList notEmpty]
        whileTrue:
          [copy _ workList removeLast.
            source _ copy at: 2.
            remap
              at: source register
              ifPresent:
                [:newSource |
                  copy at: 2 put: newSource]
              ifAbsent:
                [copy at: 2 put: source register].
            aBasicBlock
              add:
                (((copy at: 2) isKindOf: RegisterVariable)
                  ifTrue:
                    [ReloadInstruction new operands: copy]
                  ifFalse:
                    [MoveInstruction new operands: copy]).
            remap at: source register put: (copy at: 1).
            (copies
              detect: [:nextCopy | (nextCopy at: 1) == source register]
              ifNone: [])
              ifNotNilDo:
                [:nextCopy |
                  workList add: nextCopy]].
        copies notEmpty
          ifTrue:
            [copy _ copies removeLast.
              workList add: copy.
              source _ copy at: 2.
              aBasicBlock freeOut notEmpty
                ifTrue:
                  [temporary _ aBasicBlock freeOut anyone.
                    aBasicBlock freeOut remove: temporary.
                    modifiedRegisters add: temporary.
                    remap at: source register put: temporary.
                    aBasicBlock
                      add:
                        (MoveInstruction new
                          operands:
                            (Array
                              with: temporary
                              with: source register))]
                ifFalse:
                  [remap at: source register put: source variable.
                    source damaged
                      ifTrue:
                        [aBasicBlock
                          add:
                            (SpillInstruction new
                              operands:
                                (Array
                                  with: source variable
                                  with: source register))]]]].
  reloads
    do:
      [:reload |
        aBasicBlock add: reload]! !

!RegisterAllocator methodsFor: 'analyzing' stamp: 'lrs 05/26/2002 11:14'!
computeLiveness
  function entry
    doDominatorTreeBeforeDescent:
      [:basicBlock |
        basicBlock liveIn: nil.
        basicBlock liveOut: nil].
  function exit liveOut: function outputVariables asSet.
  function entry region
    doBackwardDataflow:
      [:basicBlock |
        basicBlock liveOut
          ifNil:
            [basicBlock liveOut: Set new].
        basicBlock
          doSuccessors:
            [:successor |
              successor liveIn
                ifNotNil:
                  [basicBlock liveOut addAll: successor liveIn]].
        basicBlock liveIn: basicBlock liveOut copy.
        basicBlock
          reverseDo:
            [:instruction |
              instruction
                doOutputOperands:
                  [:operand |
                    region liveIn remove: operand ifAbsent: []]
                ifKindOf: RegisterVariable.
              instruction
                doInputOperands:
                  [:operand |
                    basicBlock liveIn add: operand]
                ifKindOf: RegisterVariable]]! !

!RegisterAllocator methodsFor: 'analysis' stamp: 'lrs 05/26/2002 11:14'!
computeLiveRangesFor: aBasicBlock
  aBasicBlock liveOut
    do:
      [:registerVariable |
        registerVariable useLiveRangeAt: currentTime].
  allocatedVariables
    do:
      [:registerVariable |
        (aBasicBlock liveOut includes: registerVariable)
          ifFalse:
            [allocatedVariables remove: registerVariable.
              registerVariable defineLiveRangeAt: currentTime]].
  allocatedVariables addAll: liveOut.
  aBasicBlock
    reverseDo:
      [:instruction |
        currentTime _ currentTime - 1.
        instruction
          doOutputOperands:
            [:operand |
              allocatedVariables remove: operand ifAbsent: [].
              operand defineLiveRangeAt: currentTime.
              operand weight: instruction]
          ifKindOf: RegisterVariable.
        instruction
          doInputOperands:
            [:operand |
              allocatedVariables add: operand.
              operand useLiveRangeAt: currentTime.
              operand weight: instruction]
          ifKindOf: RegisterVariable].
  aBasicBlock entrances
    ifNil:
      [liveIn
        do: 
          [:registerVariable |
            registerVariable defineLiveRangeAt: currentTime]]! !

!RegisterAllocator methodsFor: 'restructuring' stamp: 'lrs 05/26/2002 11:14'!
allocateRegistersFor: aBasicBlock
  | calleeRegisters |
  aBasicBlock locationIn: Dictionary new: allocatedVariables size.
  aBasicBlock liveIn
    do:
      [:registerVariable |
        "Ensure that the register set is consistent. Lifetime holes injure it."
        (registerVariable liveAt: currentTime)
          ifTrue:
            [freeRegisters 
              remove: registerVariable register
              ifAbsent: []]].
  allocatedVariables
    do:
      [:registerVariable |
        aBasicBlock locationIn  
          at: registerVariable
          put: (registerVariable locationAt: currentTime).
        (aBasicBlockliveIn includes: registerVariable)
          ifFalse:
            [freeRegisters add: registerVariable register]].
  aBasicBlock
    do:
      [:instruction |
        (instruction isKindOf: CallInstruction)
          ifTrue:
            [(instruction atInputOperand: 1)
              ifKindOf: FunctionLabel
              thenDo:
                [:label |
                  calleeRegisters _ label target allocatedRegisters].
              allocatedSet
                do:
                  [:registerVariable |
                    ((registerVariable liveAt: currentTime)
                      and: 
                        [function compilationUnit architecture callerSaveRegisters
                          includes: registerVariable register]
                      and:
                        [calleeRegisters isNil or: 
                          [calleeRegisters includes: registerVariable register]])
                      ifTrue:
                        [self 
                          spillVariable: aRegisterVariable 
                          forDefinition: instruction]]].
        instruction
          doInputOperands:
            [:operand |
              operand spilled
                ifTrue:
                  [self
                    reloadRegisterFor: operand
                    inUse: instruction]]
          ifKindOf: RegisterVariable.
        instruction
          doInputOperands:
            [:operand |
              operand liveRanges first end <= currentTime
                ifTrue:
                  [operand removeLiveRangeAt: currentTime.
                    operand liveRanges isEmpty
                      ifTrue:
                        [operand register useCount: operand register useCount - 1.
                          operand register useCount = 0
                            ifTrue:
                             [freeRegisters remove: operand register]]]]
          ifKindOf: RegisterVariable.
        instruction
          doOutputOperands:
            [:operand |
              (operand liveAt: currentTime)
                ifFalse:
                  [self
                    allocateRegisterTo: operand
                    inDefinition: instruction]]
          ifKindOf: RegisterVariable.
        instruction operands
          withIndexDo:
            [:operand :index |
              (operand isKindOf: RegisterVariable)
                ifTrue: [instruction operands at: index put: operand register]]].
  aBasicBlock freeOut: freeRegisters copy.
  aBasicBlock locationOut: Dictionary new: allocatedSet size.
  allocatedVariables
    do:
      [:registerVariable |
        (registerVariable holeAt: currentTime)
          ifTrue:
            [aBasicBlock freeOut add: registerVariable register]
          ifFalse:
            [aBasicBlock locationOut
              at: registerVariable
              put: (registerVariable locationAt: currentTime)]]! !

!RegisterAllocator methodsFor: 'accounting' stamp: 'lrs 05/26/2002 11:14'!
reloadRegisterFor: aRegisterVariable inUse: anInstruction
  | register |
  register _ self
               allocateRegisterTo: aRegisterVariable
               inDefinition: anInstruction.
  anInstruction basicBlock
    add: 
      (ReloadInstruction new
        operands:
          (Array with: register with: aRegisterVariable))
    before: anInstruction.
  ^ register! !

!RegisterAllocator methodsFor: 'accounting' stamp: 'lrs 05/26/2002 11:14'!
spillVariable: aRegisterVariable forDefinition: anInstruction
  aRegisterVariable damaged
    ifTrue:
      [anInstruction basicBlock
        add:
          (SpillInstruction new
            operands:
              (Array 
                with: aRegisterVariable
                with: aRegisterVariable register))
        before: anInstruction].
  aRegisterVariable spilled: true.
  aRegisterVariable damaged: false.
  aRegisterVariable register 
    useCount: 
      aRegisterVariable register useCount - 1! !

!RegisterAllocator methodsFor: 'accounting' stamp: 'lrs 05/26/2002 11:14'!
evictRegisterFor: aRegisterVariable inDefinition: anInstruction
  | evictee |
  aRegisterVariable usesFixedRegister
    ifTrue:
      [evictee _ allocatedVariables
                   detect:
                     [:candidate |
                       (candidate liveAt: anInteger)
                         and: [candidate register == aRegisterVariable register]]
                   ifNone:
                     [^ aRegisterVariable register]]
    ifFalse:
      [evictee _ allocatedVariables
                   detectMax:
                     [:candidate | 
                       ((candidate liveAt: anInteger)
                         and: 
                           [candidate register storageType
                             mayContain:
                               aRegisterVariable storageType])
                         ifTrue: [candidate weight]
                         ifFalse: [0]]].
  self spillVariable: evictee forDefinition: anInstruction.
  ^ evictee register! !

!RegisterAllocator methodsFor: 'accounting' stamp: 'lrs 05/26/2002 11:14'!
chooseRegisterFor: aRegisterVariable
  | choice register |
  aRegisterVariable usesFixedRegister
    ifTrue:
      [(freeRegisters includes: aRegisterVariable register)
        ifTrue:
          [^ aRegisterVariable register].
        ^ nil].
  choice _ allocatedVariables
             detectMin:
               [:candidate |
                 ((candidate holeIncludes: aRegisterVariable)
                   and:
                     [candidate register storageType
                       mayContain:
                         aRegisterVariable storageType])
                   ifTrue: [candidate liveRanges first start]
                   ifFalse: [SmallInteger maxVal]].
  choice
    ifNil:
      [register _ freeRegisters
                    detect:
                      [:candidate |
                        candidate storageType
                          mayContain:
                            aRegisterVariable storageType]
                    ifNone: [].
        register
          ifNotNil:
            [freeRegisters remove: register]
          ifNil:
            [register _ calleeSaveRegisters
                          detect:
                            [:candidate |
                              candidate storageType
                                mayContain:
                                  aRegisterVariable storageType]
                          ifNone: [].
              register
                ifNotNil:
                  [calleeSaveRegisters remove: register]
                ifNil:
                  [choice _ allocateSet
                              detectMax:
                                [:candidate |
                                  ((candidate holeAt: anInteger)
                                    and:
                                      [candidate register storageType
                                        mayContain:
                                          aRegisterVariable storageType])
                                    ifTrue: [candidate weight]
                                    ifFalse: [0]]]]].
  choice
    ifNotNil:
      [^ choice register].
  ^ register! !

!RegisterAllocator methodsFor: 'accounting' stamp: 'lrs 05/26/2002 11:14'!
allocateRegisterTo: aRegisterVariable inDefinition: anInstruction
  | register |
  register _ self chooseRegisterFor: aRegisterVariable.
  register
    ifNil:
      [register _ self
                    evictRegisterFor: aRegisterVariable
                    inDefinition: anInstruction].
  aRegisterVariable register isNil | aRegisterVariable spilled
    ifTrue:
      [allocatedVariables add: aRegisterVariable.
        register useCount: register useCount + 1].
  aRegisterVariable spilled: false.
  aRegisterVariable damaged: true.
  aRegisterVariable register: register.
  modifiedRegisters add: register.
  ^ register! !