+{-# OPTIONS -fno-warn-missing-signatures #-}
-- | Clean out unneeded spill/reload instrs
--
+-- * Handling of join points
+--
+-- B1: B2:
+-- ... ...
+-- RELOAD SLOT(0), %r1 RELOAD SLOT(0), %r1
+-- ... A ... ... B ...
+-- jump B3 jump B3
+--
+-- B3: ... C ...
+-- RELOAD SLOT(0), %r1
+-- ...
+--
+-- the plan:
+-- So long as %r1 hasn't been written to in A, B or C then we don't need the
+-- reload in B3.
+--
+-- What we really care about here is that on the entry to B3, %r1 will always
+-- have the same value that is in SLOT(0) (ie, %r1 is _valid_)
+--
+-- This also works if the reloads in B1/B2 were spills instead, because
+-- spilling %r1 to a slot makes that slot have the same value as %r1.
+--
+
module RegSpillClean (
cleanSpills
)
where
+import BlockId
import RegLiveness
import RegAllocInfo
import MachRegs
import Cmm
import UniqSet
+import UniqFM
+import Unique
+import State
+import Outputable
+import Util
+
+import Data.Maybe
+import Data.List ( find, nub )
+
+--
+type Slot = Int
-- | Clean out unneeded spill/reloads from this top level thing.
cleanSpills :: LiveCmmTop -> LiveCmmTop
cleanSpills cmm
- = mapBlockTop cleanBlock cmm
- where
- cleanBlock (BasicBlock id instrs)
- = BasicBlock id
- $ cleanSpill emptyUniqSet []
- $ cleanReload emptyUniqSet []
- $ instrs
+ = evalState (cleanSpin 0 cmm) initCleanS
+
+-- | do one pass of cleaning
+cleanSpin :: Int -> LiveCmmTop -> CleanM LiveCmmTop
+
+{-
+cleanSpin spinCount code
+ = do jumpValid <- gets sJumpValid
+ pprTrace "cleanSpin"
+ ( int spinCount
+ $$ text "--- code"
+ $$ ppr code
+ $$ text "--- joins"
+ $$ ppr jumpValid)
+ $ cleanSpin' spinCount code
+-}
+
+cleanSpin spinCount code
+ = do
+ -- init count of cleaned spills/reloads
+ modify $ \s -> s
+ { sCleanedSpillsAcc = 0
+ , sCleanedReloadsAcc = 0
+ , sReloadedBy = emptyUFM }
+
+ code_forward <- mapBlockTopM cleanBlockForward code
+ code_backward <- mapBlockTopM cleanBlockBackward code_forward
+
+ -- During the cleaning of each block we collected information about what regs
+ -- were valid across each jump. Based on this, work out whether it will be
+ -- safe to erase reloads after join points for the next pass.
+ collateJoinPoints
+
+ -- remember how many spills/reloads we cleaned in this pass
+ spills <- gets sCleanedSpillsAcc
+ reloads <- gets sCleanedReloadsAcc
+ modify $ \s -> s
+ { sCleanedCount = (spills, reloads) : sCleanedCount s }
+
+ -- if nothing was cleaned in this pass or the last one
+ -- then we're done and it's time to bail out
+ cleanedCount <- gets sCleanedCount
+ if take 2 cleanedCount == [(0, 0), (0, 0)]
+ then return code
+
+ -- otherwise go around again
+ else cleanSpin (spinCount + 1) code_backward
+
+
+-- | Clean one basic block
+cleanBlockForward :: LiveBasicBlock -> CleanM LiveBasicBlock
+cleanBlockForward (BasicBlock blockId instrs)
+ = do
+ -- see if we have a valid association for the entry to this block
+ jumpValid <- gets sJumpValid
+ let assoc = case lookupUFM jumpValid blockId of
+ Just assoc -> assoc
+ Nothing -> emptyAssoc
+
+ instrs_reload <- cleanForward blockId assoc [] instrs
+ return $ BasicBlock blockId instrs_reload
+
+
+cleanBlockBackward :: LiveBasicBlock -> CleanM LiveBasicBlock
+cleanBlockBackward (BasicBlock blockId instrs)
+ = do instrs_spill <- cleanBackward emptyUniqSet [] instrs
+ return $ BasicBlock blockId instrs_spill
+
+
-- | Clean out unneeded reload instructions.
-- Walking forwards across the code
--- If there are no writes to a reg between a reload and the
--- last spill or reload then we don't need the reload.
+-- On a reload, if we know a reg already has the same value as a slot
+-- then we don't need to do the reload.
--
-cleanReload
- :: UniqSet Reg -- ^ hregs that were reloaded but not written to yet
+cleanForward
+ :: BlockId -- ^ the block that we're currently in
+ -> Assoc Store -- ^ two store locations are associated if they have the same value
-> [LiveInstr] -- ^ acc
-> [LiveInstr] -- ^ instrs to clean (in backwards order)
- -> [LiveInstr] -- ^ cleaned instrs (in forward order)
+ -> CleanM [LiveInstr] -- ^ cleaned instrs (in forward order)
+
+cleanForward _ _ acc []
+ = return acc
+
+-- write out live range joins via spill slots to just a spill and a reg-reg move
+-- hopefully the spill will be also be cleaned in the next pass
+--
+cleanForward blockId assoc acc (Instr i1 live1 : Instr i2 _ : instrs)
+
+ | SPILL reg1 slot1 <- i1
+ , RELOAD slot2 reg2 <- i2
+ , slot1 == slot2
+ = do
+ modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+ cleanForward blockId assoc acc
+ (Instr i1 live1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs)
+
+
+cleanForward blockId assoc acc (li@(Instr i1 _) : instrs)
+ | Just (r1, r2) <- isRegRegMove i1
+ = if r1 == r2
+ -- erase any left over nop reg reg moves while we're here
+ -- this will also catch any nop moves that the "write out live range joins" case above
+ -- happens to add
+ then cleanForward blockId assoc acc instrs
-cleanReload valid acc [] = acc
-cleanReload valid acc (li@(Instr instr live) : instrs)
+ -- if r1 has the same value as some slots and we copy r1 to r2,
+ -- then r2 is now associated with those slots instead
+ else do let assoc' = addAssoc (SReg r1) (SReg r2)
+ $ delAssoc (SReg r2)
+ $ assoc
+
+ cleanForward blockId assoc' (li : acc) instrs
+
+
+cleanForward blockId assoc acc (li@(Instr instr _) : instrs)
+
+ -- update association due to the spill
| SPILL reg slot <- instr
- , valid' <- addOneToUniqSet valid reg
- = cleanReload valid' (li : acc) instrs
+ = let assoc' = addAssoc (SReg reg) (SSlot slot)
+ $ delAssoc (SSlot slot)
+ $ assoc
+ in cleanForward blockId assoc' (li : acc) instrs
+
+ -- clean a reload instr
+ | RELOAD{} <- instr
+ = do (assoc', mli) <- cleanReload blockId assoc li
+ case mli of
+ Nothing -> cleanForward blockId assoc' acc instrs
+ Just li' -> cleanForward blockId assoc' (li' : acc) instrs
+
+ -- remember the association over a jump
+ | targets <- jumpDests instr []
+ , not $ null targets
+ = do mapM_ (accJumpValid assoc) targets
+ cleanForward blockId assoc (li : acc) instrs
+
+ -- writing to a reg changes its value.
+ | RU _ written <- regUsage instr
+ = let assoc' = foldr delAssoc assoc (map SReg $ nub written)
+ in cleanForward blockId assoc' (li : acc) instrs
+
+
+-- | Try and rewrite a reload instruction to something more pleasing
+--
+cleanReload :: BlockId -> Assoc Store -> LiveInstr -> CleanM (Assoc Store, Maybe LiveInstr)
+cleanReload blockId assoc li@(Instr (RELOAD slot reg) _)
+
+ -- if the reg we're reloading already has the same value as the slot
+ -- then we can erase the instruction outright
+ | elemAssoc (SSlot slot) (SReg reg) assoc
+ = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+ return (assoc, Nothing)
+
+ -- if we can find another reg with the same value as this slot then
+ -- do a move instead of a reload.
+ | Just reg2 <- findRegOfSlot assoc slot
+ = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+
+ let assoc' = addAssoc (SReg reg) (SReg reg2)
+ $ delAssoc (SReg reg)
+ $ assoc
+
+ return (assoc', Just $ Instr (mkRegRegMoveInstr reg2 reg) Nothing)
+
+ -- gotta keep this instr
+ | otherwise
+ = do -- update the association
+ let assoc' = addAssoc (SReg reg) (SSlot slot) -- doing the reload makes reg and slot the same value
+ $ delAssoc (SReg reg) -- reg value changes on reload
+ $ assoc
- | RELOAD slot reg <- instr
- = if elementOfUniqSet reg valid
- then cleanReload valid acc instrs
- else cleanReload (addOneToUniqSet valid reg) (li : acc) instrs
+ -- remember that this block reloads from this slot
+ accBlockReloadsSlot blockId slot
- | RU read written <- regUsage instr
- , valid' <- minusUniqSet valid (mkUniqSet written)
- = cleanReload valid' (li : acc) instrs
+ return (assoc', Just li)
+
+cleanReload _ _ _
+ = panic "RegSpillClean.cleanReload: unhandled instr"
-- | Clean out unneeded spill instructions.
--- Walking backwards across the code.
+--
-- If there were no reloads from a slot between a spill and the last one
-- then the slot was never read and we don't need the spill.
-
-cleanSpill
- :: UniqSet Int -- ^ slots that have been spilled, but not reload from
+--
+-- SPILL r0 -> s1
+-- RELOAD s1 -> r2
+-- SPILL r3 -> s1 <--- don't need this spill
+-- SPILL r4 -> s1
+-- RELOAD s1 -> r5
+--
+-- Maintain a set of
+-- "slots which were spilled to but not reloaded from yet"
+--
+-- Walking backwards across the code:
+-- a) On a reload from a slot, remove it from the set.
+--
+-- a) On a spill from a slot
+-- If the slot is in set then we can erase the spill,
+-- because it won't be reloaded from until after the next spill.
+--
+-- otherwise
+-- keep the spill and add the slot to the set
+--
+-- TODO: This is mostly inter-block
+-- we should really be updating the noReloads set as we cross jumps also.
+--
+cleanBackward
+ :: UniqSet Int -- ^ slots that have been spilled, but not reloaded from
-> [LiveInstr] -- ^ acc
-> [LiveInstr] -- ^ instrs to clean (in forwards order)
- -> [LiveInstr] -- ^ cleaned instrs (in backwards order)
+ -> CleanM [LiveInstr] -- ^ cleaned instrs (in backwards order)
-cleanSpill unused acc [] = acc
-cleanSpill unused acc (li@(Instr instr live) : instrs)
- | SPILL reg slot <- instr
- = if elementOfUniqSet slot unused
- then cleanSpill unused acc instrs
- else cleanSpill (addOneToUniqSet unused slot) (li : acc) instrs
- | RELOAD slot reg <- instr
- , unused' <- delOneFromUniqSet unused slot
- = cleanSpill unused' (li : acc) instrs
+cleanBackward noReloads acc lis
+ = do reloadedBy <- gets sReloadedBy
+ cleanBackward' reloadedBy noReloads acc lis
+
+cleanBackward' _ _ acc []
+ = return acc
+
+cleanBackward' reloadedBy noReloads acc (li@(Instr instr _) : instrs)
+
+ -- if nothing ever reloads from this slot then we don't need the spill
+ | SPILL _ slot <- instr
+ , Nothing <- lookupUFM reloadedBy (SSlot slot)
+ = do modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
+ cleanBackward noReloads acc instrs
+
+ | SPILL _ slot <- instr
+ = if elementOfUniqSet slot noReloads
+
+ -- we can erase this spill because the slot won't be read until after the next one
+ then do
+ modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
+ cleanBackward noReloads acc instrs
+
+ else do
+ -- this slot is being spilled to, but we haven't seen any reloads yet.
+ let noReloads' = addOneToUniqSet noReloads slot
+ cleanBackward noReloads' (li : acc) instrs
+
+ -- if we reload from a slot then it's no longer unused
+ | RELOAD slot _ <- instr
+ , noReloads' <- delOneFromUniqSet noReloads slot
+ = cleanBackward noReloads' (li : acc) instrs
+
+ -- some other instruction
+ | otherwise
+ = cleanBackward noReloads (li : acc) instrs
+
+
+-- 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
+
+
+-- | See if we have a reg with the same value as this slot in the association table.
+findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
+findRegOfSlot assoc slot
+ | close <- closeAssoc (SSlot slot) assoc
+ , Just (SReg reg) <- find isStoreReg $ uniqSetToList close
+ = Just reg
| otherwise
- = cleanSpill unused (li : acc) instrs
+ = Nothing
+
+
+---------------
+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]
+
+ -- map of (slot -> blocks which reload from this slot)
+ -- used to decide if whether slot spilled to will ever be
+ -- reloaded from on this path.
+ , sReloadedBy :: UniqFM [BlockId]
+
+ -- 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
+
+ , sReloadedBy = 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] }
+
+
+accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
+accBlockReloadsSlot blockId slot
+ = modify $ \s -> s {
+ sReloadedBy = addToUFM_C (++)
+ (sReloadedBy s)
+ (SSlot slot)
+ [blockId] }
+
+
+--------------
+-- A store location can be a stack slot or a register
+--
+data Store
+ = SSlot Int
+ | SReg Reg
+
+-- | Check if this is a reg store
+isStoreReg :: Store -> Bool
+isStoreReg ss
+ = case ss of
+ SSlot _ -> False
+ SReg _ -> True
+
+-- 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
projects / ghc-hetmet.git / blobdiff