-- (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,
stripLive,
spillNatBlock,
slurpConflicts,
- lifetimeCount,
+ slurpReloadCoalesce,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
import MachInstrs
import PprMach
import RegAllocInfo
-import Cmm
+import Cmm hiding (RegSet)
import Digraph
import Outputable
import UniqSupply
import Bag
import State
+import FastString
import Data.List
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
= 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.
=> (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'
-- 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) ()
-- | 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.
= 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)
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.
, 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
= 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
spillNat acc []
= return (reverse acc)
- spillNat acc (instr@(DELTA i) : instrs)
+ spillNat acc (DELTA i : instrs)
= do put i
spillNat acc instrs
= 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
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
:: 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
in returnUs $ CmmProc
(LiveInfo info (Just first_id) block_live)
- lbl params liveBlocks
+ lbl params (ListGraph liveBlocks)
sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
-> 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)
:: 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.
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
-> [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
projects / ghc-hetmet.git / blobdiff