From: Ben.Lippmeier@anu.edu.au Date: Tue, 11 Sep 2007 17:38:33 +0000 (+0000) Subject: Try and rewrite reloads to reg-reg moves in the spill cleaner X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=86f1f4e0748ba1146cf74786af38a68a88164e2f Try and rewrite reloads to reg-reg moves in the spill cleaner --- diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs index b55d8c0..e18931c 100644 --- a/compiler/nativeGen/RegLiveness.hs +++ b/compiler/nativeGen/RegLiveness.hs @@ -254,8 +254,6 @@ slurpConflicts live -- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely -- the spill/reload instrs can be cleaned and replaced by a nop reg-reg move. -- --- TODO: This only works intra-block at the momement. It's be nice to join up the mappings --- across blocks also. -- slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg) slurpReloadCoalesce live @@ -265,32 +263,80 @@ slurpReloadCoalesce live slurpCmm cs (CmmProc _ _ _ (ListGraph blocks)) = foldl' slurpComp cs blocks - slurpComp cs (BasicBlock _ blocks) - = foldl' slurpBlock cs blocks + slurpComp cs comp + = let (moveBags, _) = runState (slurpCompM comp) emptyUFM + in unionManyBags (cs : moveBags) - slurpBlock cs (BasicBlock _ instrs) - = let (_, mMoves) = mapAccumL slurpLI emptyUFM instrs - in unionBags cs (listToBag $ catMaybes mMoves) + slurpCompM (BasicBlock _ blocks) + = do -- run the analysis once to record the mapping across jumps. + mapM_ (slurpBlock False) blocks + + -- run it a second time while using the information from the last pass. + -- We /could/ run this many more times to deal with graphical control + -- flow and propagating info across multiple jumps, but it's probably + -- not worth the trouble. + mapM (slurpBlock True) blocks + + slurpBlock propagate (BasicBlock blockId instrs) + = do -- grab the slot map for entry to this block + slotMap <- if propagate + then getSlotMap blockId + else return emptyUFM + + (_, mMoves) <- mapAccumLM slurpLI slotMap instrs + return $ listToBag $ catMaybes mMoves + + slurpLI :: UniqFM Reg -- current slotMap + -> LiveInstr + -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] + -- for tracking slotMaps across jumps + + ( UniqFM Reg -- new slotMap + , Maybe (Reg, Reg)) -- maybe a new coalesce edge - slurpLI :: UniqFM Reg -> LiveInstr -> (UniqFM Reg, Maybe (Reg, Reg)) slurpLI slotMap (Instr instr _) -- remember what reg was stored into the slot | SPILL reg slot <- instr , slotMap' <- addToUFM slotMap slot reg - = (slotMap', Nothing) + = return (slotMap', Nothing) -- add an edge betwen the this reg and the last one stored into the slot | RELOAD slot reg <- instr = case lookupUFM slotMap slot of Just reg2 - | reg /= reg2 -> (slotMap, Just (reg, reg2)) - | otherwise -> (slotMap, Nothing) + | reg /= reg2 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (slotMap, Nothing) - Nothing -> (slotMap, Nothing) + -- if we hit a jump, remember the current slotMap + | targets <- jumpDests instr [] + , not $ null targets + = do mapM_ (accSlotMap slotMap) targets + return (slotMap, Nothing) | otherwise - = (slotMap, Nothing) + = return (slotMap, Nothing) + + -- record a slotmap for an in edge to this block + accSlotMap slotMap blockId + = modify (\s -> addToUFM_C (++) s blockId [slotMap]) + + -- work out the slot map on entry to this block + -- if we have slot maps for multiple in-edges then we need to merge them. + getSlotMap blockId + = do map <- get + let slotMaps = fromMaybe [] (lookupUFM map blockId) + return $ foldr mergeSlotMaps emptyUFM slotMaps + + mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg + mergeSlotMaps map1 map2 + = listToUFM + $ [ (k, r1) | (k, r1) <- ufmToList map1 + , case lookupUFM map2 k of + Nothing -> False + Just r2 -> r1 == r2 ] -- | Strip away liveness information, yielding NatCmmTop diff --git a/compiler/nativeGen/RegSpillClean.hs b/compiler/nativeGen/RegSpillClean.hs index 2db4d74..ea36a5e 100644 --- a/compiler/nativeGen/RegSpillClean.hs +++ b/compiler/nativeGen/RegSpillClean.hs @@ -101,7 +101,7 @@ cleanBlock (BasicBlock id instrs) Just assoc -> assoc Nothing -> emptyAssoc - instrs_reload <- cleanReload assoc [] instrs + instrs_reload <- cleanFwd assoc [] instrs instrs_spill <- cleanSpill emptyUniqSet [] instrs_reload return $ BasicBlock id instrs_spill @@ -111,36 +111,36 @@ cleanBlock (BasicBlock id instrs) -- 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 +cleanFwd :: Assoc Store -- ^ two store locations are associated if they have the same value -> [LiveInstr] -- ^ acc -> [LiveInstr] -- ^ instrs to clean (in backwards order) -> CleanM [LiveInstr] -- ^ cleaned instrs (in forward order) -cleanReload _ acc [] +cleanFwd _ 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 -- -cleanReload assoc acc (Instr i1 live1 : Instr i2 _ : instrs) +cleanFwd 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 } - cleanReload assoc acc + cleanFwd assoc acc (Instr i1 live1 : Instr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs) -cleanReload assoc acc (li@(Instr i1 _) : instrs) +cleanFwd 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 cleanReload assoc acc instrs + then cleanFwd assoc acc 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 @@ -148,43 +148,69 @@ cleanReload assoc acc (li@(Instr i1 _) : instrs) $ delAssoc (SReg r2) $ assoc - cleanReload assoc' (li : acc) instrs + cleanFwd assoc' (li : acc) instrs -cleanReload assoc acc (li@(Instr instr _) : instrs) +cleanFwd assoc acc (li@(Instr instr _) : instrs) | SPILL reg slot <- instr = let assoc' = addAssoc (SReg reg) (SSlot slot) -- doing the spill makes reg and slot the same value $ delAssoc (SSlot slot) -- slot value changes on spill $ assoc - in cleanReload assoc' (li : acc) instrs + in cleanFwd assoc' (li : acc) instrs - | RELOAD slot reg <- instr - = if elemAssoc (SSlot slot) (SReg reg) assoc - - -- if the reg and slot had the same value before reload - -- then we don't need the reload. - then do - modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - cleanReload assoc acc instrs - - -- reg and slot had different values before reload - else - 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 - in cleanReload assoc' (li : acc) instrs + -- clean a reload instr + | RELOAD{} <- instr + = do (assoc', mli) <- cleanReload assoc li + case mli of + Nothing -> cleanFwd assoc' acc instrs + Just li' -> cleanFwd assoc' (li' : acc) instrs -- remember the association over a jump | targets <- jumpDests instr [] , not $ null targets = do mapM_ (accJumpValid assoc) targets - cleanReload assoc (li : acc) instrs + cleanFwd 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 cleanReload assoc' (li : acc) instrs + in cleanFwd assoc' (li : acc) instrs + + +-- | Try and rewrite a reload instruction to something more pleasing +-- +cleanReload :: Assoc Store -> LiveInstr -> CleanM (Assoc Store, Maybe LiveInstr) +cleanReload 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 + -- update the association + | otherwise + = do 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 + + return (assoc', Just li) + +cleanReload _ _ + = panic "RegSpillClean.cleanReload: unhandled instr" -- | Clean out unneeded spill instructions. @@ -240,6 +266,16 @@ 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 + = Nothing + --------------- type CleanM = State CleanS @@ -288,6 +324,13 @@ 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