'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: