X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegLiveness.hs;h=9a23ef4129744823a0df27de23b797a453ee9507;hb=e1ca482b971739838cb5aa46dbc5b17bdf5c97c4;hp=b55d8c097f0303158dc76024c283a14ba31ca6dd;hpb=9d2b0ebb2a6c43d6cd4f27e763897cc06592f5a0;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs index b55d8c0..9a23ef4 100644 --- a/compiler/nativeGen/RegLiveness.hs +++ b/compiler/nativeGen/RegLiveness.hs @@ -23,7 +23,6 @@ module RegLiveness ( spillNatBlock, slurpConflicts, slurpReloadCoalesce, - lifetimeCount, eraseDeltasLive, patchEraseLive, patchRegsLiveInstr, @@ -31,8 +30,6 @@ module RegLiveness ( ) where -#include "HsVersions.h" - import MachRegs import MachInstrs import PprMach @@ -47,6 +44,7 @@ import UniqFM import UniqSupply import Bag import State +import FastString import Data.List import Data.Maybe @@ -113,9 +111,9 @@ instance Outputable LiveInstr where = ppr instr $$ (nest 8 $ vcat - [ pprRegs (ptext SLIT("# born: ")) (liveBorn live) - , pprRegs (ptext SLIT("# r_dying: ")) (liveDieRead live) - , pprRegs (ptext SLIT("# w_dying: ")) (liveDieWrite live) ] + [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) + , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) + , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] $+$ space) where pprRegs :: SDoc -> RegSet -> SDoc @@ -254,8 +252,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 +261,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) + + 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 - slurpBlock cs (BasicBlock _ instrs) - = let (_, mMoves) = mapAccumL slurpLI emptyUFM instrs - in unionBags cs (listToBag $ catMaybes mMoves) + (_, 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 @@ -335,48 +379,6 @@ spillNatBlock (BasicBlock i is) = spillNat (instr : acc) instrs --- | Slurp out a map of how many times each register was live upon entry to an instruction. - -lifetimeCount - :: LiveCmmTop - -> UniqFM (Reg, Int) -- ^ reg -> (reg, count) - -lifetimeCount cmm - = countCmm emptyUFM cmm - where - countCmm fm CmmData{} = fm - countCmm fm (CmmProc info _ _ (ListGraph blocks)) - = foldl' (countComp info) fm blocks - - countComp info fm (BasicBlock _ blocks) - = foldl' (countBlock info) fm blocks - - countBlock info fm (BasicBlock blockId instrs) - | LiveInfo _ _ blockLive <- info - , Just rsLiveEntry <- lookupUFM blockLive blockId - = countLIs rsLiveEntry fm instrs - - | otherwise - = error "RegLiveness.countBlock: bad block" - - countLIs _ fm [] = fm - countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis - - countLIs rsLiveEntry fm (Instr _ (Just live) : lis) - = let - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) - - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) - - add r fm = addToUFM_C - (\(r1, l1) (_, l2) -> (r1, l1 + l2)) - fm r (r, 1) - - fm' = foldUniqSet add fm rsLiveEntry - in countLIs rsLiveNext fm' lis - - -- | Erase Delta instructions. eraseDeltasLive :: LiveCmmTop -> LiveCmmTop