X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegLiveness.hs;h=6bee0c85fc7efcaf7011c9d2ac68bfb9f4b1b671;hp=f2db089882403c82c69c60631056ec06dfa6c62a;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4 diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs index f2db089..6bee0c8 100644 --- a/compiler/nativeGen/RegLiveness.hs +++ b/compiler/nativeGen/RegLiveness.hs @@ -5,13 +5,7 @@ -- (c) The University of Glasgow 2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} module RegLiveness ( RegSet, @@ -28,7 +22,7 @@ module RegLiveness ( stripLive, spillNatBlock, slurpConflicts, - lifetimeCount, + slurpReloadCoalesce, eraseDeltasLive, patchEraseLive, patchRegsLiveInstr, @@ -42,7 +36,7 @@ import MachRegs import MachInstrs import PprMach import RegAllocInfo -import Cmm +import Cmm hiding (RegSet) import Digraph import Outputable @@ -52,6 +46,7 @@ import UniqFM import UniqSupply import Bag import State +import FastString import Data.List import Data.Maybe @@ -60,9 +55,13 @@ import Data.Maybe type RegSet = UniqSet Reg type RegMap a = UniqFM a + +emptyRegMap :: UniqFM a emptyRegMap = emptyUFM type BlockMap a = UniqFM a + +emptyBlockMap :: UniqFM a emptyBlockMap = emptyUFM @@ -71,7 +70,7 @@ type LiveCmmTop = GenCmmTop CmmStatic LiveInfo - (GenBasicBlock LiveInstr) + (ListGraph (GenBasicBlock LiveInstr)) -- the "instructions" here are actually more blocks, -- single blocks are acyclic -- multiple blocks are taken to be cyclic. @@ -149,13 +148,14 @@ mapBlockTopM => (LiveBasicBlock -> m LiveBasicBlock) -> LiveCmmTop -> m LiveCmmTop -mapBlockTopM f cmm@(CmmData{}) +mapBlockTopM _ cmm@(CmmData{}) = return cmm -mapBlockTopM f (CmmProc header label params comps) +mapBlockTopM f (CmmProc header label params (ListGraph comps)) = do comps' <- mapM (mapBlockCompM f) comps - return $ CmmProc header label params comps' + return $ CmmProc header label params (ListGraph comps') +mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a') mapBlockCompM f (BasicBlock i blocks) = do blocks' <- mapM f blocks return $ BasicBlock i blocks' @@ -163,8 +163,8 @@ mapBlockCompM f (BasicBlock i blocks) -- map a function across all the basic blocks in this code mapGenBlockTop - :: (GenBasicBlock i -> GenBasicBlock i) - -> (GenCmmTop d h i -> GenCmmTop d h i) + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) mapGenBlockTop f cmm = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () @@ -173,15 +173,15 @@ mapGenBlockTop f cmm -- | map a function across all the basic blocks in this code (monadic version) mapGenBlockTopM :: Monad m - => (GenBasicBlock i -> m (GenBasicBlock i)) - -> (GenCmmTop d h i -> m (GenCmmTop d h i)) + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) -mapGenBlockTopM f cmm@(CmmData{}) +mapGenBlockTopM _ cmm@(CmmData{}) = return cmm -mapGenBlockTopM f (CmmProc header label params blocks) +mapGenBlockTopM f (CmmProc header label params (ListGraph blocks)) = do blocks' <- mapM f blocks - return $ CmmProc header label params blocks' + return $ CmmProc header label params (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. @@ -193,10 +193,10 @@ slurpConflicts live = slurpCmm (emptyBag, emptyBag) live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ _ blocks) + slurpCmm rs (CmmProc info _ _ (ListGraph blocks)) = foldl' (slurpComp info) rs blocks - slurpComp info rs (BasicBlock i blocks) + slurpComp info rs (BasicBlock _ blocks) = foldl' (slurpBlock info) rs blocks slurpBlock info rs (BasicBlock blockId instrs) @@ -213,7 +213,7 @@ slurpConflicts live slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis - slurpLIs rsLiveEntry (conflicts, moves) (li@(Instr instr (Just live)) : lis) + slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis) = let -- regs that die because they are read for the last time at the start of an instruction -- are not live across it. @@ -245,6 +245,100 @@ slurpConflicts live , moves) lis +-- | For spill/reloads +-- +-- SPILL v1, slot1 +-- ... +-- RELOAD slot1, v2 +-- +-- 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. +-- +-- +slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg) +slurpReloadCoalesce live + = slurpCmm emptyBag live + + where slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ _ (ListGraph blocks)) + = foldl' slurpComp 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 + + (_, 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 slotMap (Instr instr _) + + -- remember what reg was stored into the slot + | SPILL reg slot <- instr + , slotMap' <- addToUFM slotMap slot reg + = 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 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (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 + = 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 stripLive :: LiveCmmTop -> NatCmmTop @@ -252,10 +346,10 @@ stripLive live = stripCmm live where stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info _ _) label params comps) - = CmmProc info label params (concatMap stripComp comps) + stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps)) + = CmmProc info label params (ListGraph $ concatMap stripComp comps) - stripComp (BasicBlock i blocks) = map stripBlock blocks + stripComp (BasicBlock _ blocks) = map stripBlock blocks stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs) stripLI (Instr instr _) = instr @@ -271,7 +365,7 @@ spillNatBlock (BasicBlock i is) spillNat acc [] = return (reverse acc) - spillNat acc (instr@(DELTA i) : instrs) + spillNat acc (DELTA i : instrs) = do put i spillNat acc instrs @@ -287,48 +381,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 _ _ blocks) - = foldl' (countComp info) fm blocks - - countComp info fm (BasicBlock i 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 rsLive 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 @@ -357,13 +409,13 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm cmm@(CmmProc info label params comps) + patchCmm (CmmProc info label params (ListGraph comps)) | LiveInfo static id blockMap <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set blockMap' = mapUFM patchRegSet blockMap info' = LiveInfo static id blockMap' - in CmmProc info' label params $ map patchComp comps + in CmmProc info' label params $ ListGraph $ map patchComp comps patchComp (BasicBlock id blocks) = BasicBlock id $ map patchBlock blocks @@ -424,15 +476,15 @@ regLiveness :: NatCmmTop -> UniqSM LiveCmmTop -regLiveness cmm@(CmmData sec d) - = returnUs $ CmmData sec d +regLiveness (CmmData i d) + = returnUs $ CmmData i d -regLiveness cmm@(CmmProc info lbl params []) +regLiveness (CmmProc info lbl params (ListGraph [])) = returnUs $ CmmProc (LiveInfo info Nothing emptyUFM) - lbl params [] + lbl params (ListGraph []) -regLiveness cmm@(CmmProc info lbl params blocks@(first:rest)) +regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _))) = let first_id = blockId first sccs = sccBlocks blocks (ann_sccs, block_live) = computeLiveness sccs @@ -447,7 +499,7 @@ regLiveness cmm@(CmmProc info lbl params blocks@(first:rest)) in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live) - lbl params liveBlocks + lbl params (ListGraph liveBlocks) sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock] @@ -531,7 +583,7 @@ livenessBlock -> NatBasicBlock -> (BlockMap RegSet, LiveBasicBlock) -livenessBlock blockmap block@(BasicBlock block_id instrs) +livenessBlock blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) = livenessBack emptyUniqSet blockmap [] (reverse instrs) @@ -550,13 +602,13 @@ livenessForward :: RegSet -- regs live on this instr -> [LiveInstr] -> [LiveInstr] -livenessForward rsLiveEntry [] = [] +livenessForward _ [] = [] livenessForward rsLiveEntry (li@(Instr instr mLive) : lis) | Nothing <- mLive = li : livenessForward rsLiveEntry lis - | Just live <- mLive - , RU read written <- regUsage instr + | Just live <- mLive + , RU _ written <- regUsage instr = let -- Regs that are written to but weren't live on entry to this instruction -- are recorded as being born here. @@ -570,6 +622,8 @@ livenessForward rsLiveEntry (li@(Instr instr mLive) : lis) in Instr instr (Just live { liveBorn = rsBorn }) : livenessForward rsLiveNext lis +livenessForward _ _ = panic "RegLiveness.livenessForward: no match" + -- | Calculate liveness going backwards, -- filling in when regs die, and what regs are live across each instruction @@ -581,17 +635,18 @@ livenessBack -> [Instr] -- instructions -> (RegSet, [LiveInstr]) -livenessBack liveregs blockmap done [] = (liveregs, done) +livenessBack liveregs _ done [] = (liveregs, done) livenessBack liveregs blockmap acc (instr : instrs) = let (liveregs', instr') = liveness1 liveregs blockmap instr in livenessBack liveregs' blockmap (instr' : acc) instrs -- don't bother tagging comments or deltas with liveness -liveness1 liveregs blockmap (instr@COMMENT{}) +liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr) +liveness1 liveregs _ (instr@COMMENT{}) = (liveregs, Instr instr Nothing) -liveness1 liveregs blockmap (instr@DELTA{}) +liveness1 liveregs _ (instr@DELTA{}) = (liveregs, Instr instr Nothing) liveness1 liveregs blockmap instr