+
+-- collateJoinPoints:
+--
+-- | combine the associations from all the inward control flow edges.
+--
+collateJoinPoints :: CleanM ()
+collateJoinPoints
+ = modify $ \s -> s
+ { sJumpValid = mapUFM intersects (sJumpValidAcc s)
+ , sJumpValidAcc = emptyUFM }
+
+intersects :: [Assoc Store] -> Assoc Store
+intersects [] = emptyAssoc
+intersects assocs = foldl1' intersectAssoc assocs
+
+
+
+---------------
+type CleanM = State CleanS
+data CleanS
+ = CleanS
+ { -- regs which are valid at the start of each block.
+ sJumpValid :: UniqFM (Assoc Store)
+
+ -- collecting up what regs were valid across each jump.
+ -- in the next pass we can collate these and write the results
+ -- to sJumpValid.
+ , sJumpValidAcc :: UniqFM [Assoc Store]
+
+ -- spills/reloads cleaned each pass (latest at front)
+ , sCleanedCount :: [(Int, Int)]
+
+ -- spills/reloads that have been cleaned in this pass so far.
+ , sCleanedSpillsAcc :: Int
+ , sCleanedReloadsAcc :: Int }
+
+initCleanS :: CleanS
+initCleanS
+ = CleanS
+ { sJumpValid = emptyUFM
+ , sJumpValidAcc = emptyUFM
+
+ , sCleanedCount = []
+
+ , sCleanedSpillsAcc = 0
+ , sCleanedReloadsAcc = 0 }
+
+
+-- | Remember the associations before a jump
+accJumpValid :: Assoc Store -> BlockId -> CleanM ()
+accJumpValid assocs target
+ = modify $ \s -> s {
+ sJumpValidAcc = addToUFM_C (++)
+ (sJumpValidAcc s)
+ target
+ [assocs] }
+
+--------------
+-- A store location can be a stack slot or a register
+--
+data Store
+ = SSlot Int
+ | SReg Reg
+
+-- spill cleaning is only done once all virtuals have been allocated to realRegs
+--
+instance Uniquable Store where
+ getUnique (SReg r)
+ | RealReg i <- r
+ = mkUnique 'R' i
+
+ | otherwise
+ = error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected."
+
+ getUnique (SSlot i) = mkUnique 'S' i
+
+instance Outputable Store where
+ ppr (SSlot i) = text "slot" <> int i
+ ppr (SReg r) = ppr r
+
+
+--------------
+-- Association graphs.
+-- In the spill cleaner, two store locations are associated if they are known
+-- to hold the same value.
+--
+type Assoc a = UniqFM (UniqSet a)
+
+-- | an empty association
+emptyAssoc :: Assoc a
+emptyAssoc = emptyUFM
+
+
+-- | add an association between these two things
+addAssoc :: Uniquable a
+ => a -> a -> Assoc a -> Assoc a
+
+addAssoc a b m
+ = let m1 = addToUFM_C unionUniqSets m a (unitUniqSet b)
+ m2 = addToUFM_C unionUniqSets m1 b (unitUniqSet a)
+ in m2
+
+
+-- | delete all associations to a node
+delAssoc :: (Outputable a, Uniquable a)
+ => a -> Assoc a -> Assoc a
+
+delAssoc a m
+ | Just aSet <- lookupUFM m a
+ , m1 <- delFromUFM m a
+ = foldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
+
+ | otherwise = m
+
+
+-- | delete a single association edge (a -> b)
+delAssoc1 :: Uniquable a
+ => a -> a -> Assoc a -> Assoc a
+
+delAssoc1 a b m
+ | Just aSet <- lookupUFM m a
+ = addToUFM m a (delOneFromUniqSet aSet b)
+
+ | otherwise = m
+
+
+-- | check if these two things are associated
+elemAssoc :: (Outputable a, Uniquable a)
+ => a -> a -> Assoc a -> Bool
+
+elemAssoc a b m
+ = elementOfUniqSet b (closeAssoc a m)
+
+-- | find the refl. trans. closure of the association from this point
+closeAssoc :: (Outputable a, Uniquable a)
+ => a -> Assoc a -> UniqSet a
+
+closeAssoc a assoc
+ = closeAssoc' assoc emptyUniqSet (unitUniqSet a)
+ where
+ closeAssoc' assoc visited toVisit
+ = case uniqSetToList toVisit of
+
+ -- nothing else to visit, we're done
+ [] -> visited
+
+ (x:_)
+
+ -- we've already seen this node
+ | elementOfUniqSet x visited
+ -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)
+
+ -- haven't seen this node before,
+ -- remember to visit all its neighbors
+ | otherwise
+ -> let neighbors
+ = case lookupUFM assoc x of
+ Nothing -> emptyUniqSet
+ Just set -> set
+
+ in closeAssoc' assoc
+ (addOneToUniqSet visited x)
+ (unionUniqSets toVisit neighbors)
+
+-- | intersect
+intersectAssoc
+ :: Uniquable a
+ => Assoc a -> Assoc a -> Assoc a
+
+intersectAssoc a b
+ = intersectUFM_C (intersectUniqSets) a b
+