spillNatBlock,
slurpConflicts,
slurpReloadCoalesce,
- lifetimeCount,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
) where
-#include "HsVersions.h"
-
+import BlockId
import MachRegs
import MachInstrs
import PprMach
import UniqSupply
import Bag
import State
+import FastString
import Data.List
import Data.Maybe
emptyRegMap :: UniqFM a
emptyRegMap = emptyUFM
-type BlockMap a = UniqFM a
+type BlockMap a = BlockEnv a
-emptyBlockMap :: UniqFM a
-emptyBlockMap = emptyUFM
+emptyBlockMap :: BlockEnv a
+emptyBlockMap = emptyBlockEnv
-- | A top level thing which carries liveness information.
= 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
slurpBlock info rs (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive <- info
- , Just rsLiveEntry <- lookupUFM blockLive blockId
+ , Just rsLiveEntry <- lookupBlockEnv blockLive blockId
, (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
= (consBag rsLiveEntry conflicts, moves)
| otherwise
- = error "RegLiveness.slurpBlock: bad block"
+ = panic "RegLiveness.slurpBlock: bad block"
slurpLIs rsLive (conflicts, moves) []
= (consBag rsLive conflicts, moves)
, moves) lis
--- | For spill/reloads
+-- | 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.
+-- 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
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 -> (slotMap, Just (reg, reg2))
- Nothing -> (slotMap, Nothing)
+ 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
- = (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
where stripCmm (CmmData sec ds) = CmmData sec ds
stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
- = CmmProc info label params (ListGraph $ concatMap stripComp comps)
+ = CmmProc info label params
+ (ListGraph $ concatMap stripComp comps)
stripComp (BasicBlock _ blocks) = map stripBlock blocks
stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI 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 _ _ (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
patchCmm (CmmProc info label params (ListGraph comps))
| LiveInfo static id blockMap <- info
= let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
- blockMap' = mapUFM patchRegSet blockMap
+ blockMap' = mapBlockEnv patchRegSet blockMap
info' = LiveInfo static id blockMap'
in CmmProc info' label params $ ListGraph $ map patchComp comps
regLiveness (CmmProc info lbl params (ListGraph []))
= returnUs $ CmmProc
- (LiveInfo info Nothing emptyUFM)
+ (LiveInfo info Nothing emptyBlockEnv)
lbl params (ListGraph [])
regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
-> panic "RegLiveness.regLiveness: no blocks in scc list")
$ ann_sccs
- in returnUs $ CmmProc
- (LiveInfo info (Just first_id) block_live)
- lbl params (ListGraph liveBlocks)
+ in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live)
+ lbl params (ListGraph liveBlocks)
sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
-sccBlocks blocks = stronglyConnComp graph
+sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
where
getOutEdges :: [Instr] -> [BlockId]
getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
concatMap tail $
groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
iterate (\(a, _) -> f a b) $
- (a, error "RegisterAlloc.livenessSCCs")
+ (a, panic "RegLiveness.livenessSCCs")
linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
-- BlockMaps for equality.
equalBlockMaps a b
= a' == b'
- where a' = map f $ ufmToList a
- b' = map f $ ufmToList b
+ where a' = map f $ blockEnvToList a
+ b' = map f $ blockEnvToList b
f (key,elt) = (key, uniqSetToList elt)
= let
(regsLiveOnEntry, instrs1)
= livenessBack emptyUniqSet blockmap [] (reverse instrs)
- blockmap' = addToUFM blockmap block_id regsLiveOnEntry
+ blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry
instrs2 = livenessForward regsLiveOnEntry instrs1
not_a_branch = null targets
targetLiveRegs target
- = case lookupUFM blockmap target of
+ = case lookupBlockEnv blockmap target of
Just ra -> ra
- Nothing -> emptyBlockMap
+ Nothing -> emptyRegMap
live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
projects / ghc-hetmet.git / blobdiff