RegMap, emptyRegMap,
BlockMap, emptyBlockMap,
LiveCmmTop,
+ InstrSR (..),
LiveInstr (..),
Liveness (..),
LiveInfo (..),
LiveBasicBlock,
- mapBlockTop, mapBlockTopM,
+ mapBlockTop, mapBlockTopM, mapSCCM,
mapGenBlockTop, mapGenBlockTopM,
stripLive,
- spillNatBlock,
+ stripLiveBlock,
slurpConflicts,
slurpReloadCoalesce,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
- regLiveness
-
+ reverseBlocksInTops,
+ regLiveness,
+ natCmmTopToLive
) where
+import Reg
+import Instruction
import BlockId
-import Regs
-import Instrs
-import PprMach
-import RegAllocInfo
-import Cmm hiding (RegSet)
+import OldCmm hiding (RegSet)
+import OldPprCmm()
import Digraph
import Outputable
import Data.List
import Data.Maybe
+import Data.Map (Map)
+import Data.Set (Set)
+import qualified Data.Map as Map
-----------------------------------------------------------------------------
type RegSet = UniqSet Reg
type BlockMap a = BlockEnv a
-emptyBlockMap :: BlockEnv a
-emptyBlockMap = emptyBlockEnv
-
-- | A top level thing which carries liveness information.
-type LiveCmmTop
+type LiveCmmTop instr
= GenCmmTop
CmmStatic
LiveInfo
- (ListGraph (GenBasicBlock LiveInstr))
- -- the "instructions" here are actually more blocks,
- -- single blocks are acyclic
- -- multiple blocks are taken to be cyclic.
+ [SCC (LiveBasicBlock instr)]
+
+
+-- | The register allocator also wants to use SPILL/RELOAD meta instructions,
+-- so we'll keep those here.
+data InstrSR instr
+ -- | A real machine instruction
+ = Instr instr
+
+ -- | spill this reg to a stack slot
+ | SPILL Reg Int
+
+ -- | reload this reg from a stack slot
+ | RELOAD Int Reg
+
+instance Instruction instr => Instruction (InstrSR instr) where
+ regUsageOfInstr i
+ = case i of
+ Instr instr -> regUsageOfInstr instr
+ SPILL reg _ -> RU [reg] []
+ RELOAD _ reg -> RU [] [reg]
+
+ patchRegsOfInstr i f
+ = case i of
+ Instr instr -> Instr (patchRegsOfInstr instr f)
+ SPILL reg slot -> SPILL (f reg) slot
+ RELOAD slot reg -> RELOAD slot (f reg)
+
+ isJumpishInstr i
+ = case i of
+ Instr instr -> isJumpishInstr instr
+ _ -> False
+
+ jumpDestsOfInstr i
+ = case i of
+ Instr instr -> jumpDestsOfInstr instr
+ _ -> []
+
+ patchJumpInstr i f
+ = case i of
+ Instr instr -> Instr (patchJumpInstr instr f)
+ _ -> i
+
+ mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
+ mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
+
+ takeDeltaInstr i
+ = case i of
+ Instr instr -> takeDeltaInstr instr
+ _ -> Nothing
+
+ isMetaInstr i
+ = case i of
+ Instr instr -> isMetaInstr instr
+ _ -> False
+
+ mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2)
+
+ takeRegRegMoveInstr i
+ = case i of
+ Instr instr -> takeRegRegMoveInstr instr
+ _ -> Nothing
+
+ mkJumpInstr target = map Instr (mkJumpInstr target)
+
+
-- | An instruction with liveness information.
-data LiveInstr
- = Instr Instr (Maybe Liveness)
+data LiveInstr instr
+ = LiveInstr (InstrSR instr) (Maybe Liveness)
-- | Liveness information.
-- The regs which die are ones which are no longer live in the *next* instruction
-- | Stash regs live on entry to each basic block in the info part of the cmm code.
data LiveInfo
= LiveInfo
- [CmmStatic] -- cmm static stuff
- (Maybe BlockId) -- id of the first block
- (BlockMap RegSet) -- argument locals live on entry to this block
+ [CmmStatic] -- cmm static stuff
+ (Maybe BlockId) -- id of the first block
+ (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block
+ (Map BlockId (Set Int)) -- stack slots live on entry to this block
+
-- | A basic block with liveness information.
-type LiveBasicBlock
- = GenBasicBlock LiveInstr
+type LiveBasicBlock instr
+ = GenBasicBlock (LiveInstr instr)
+
+
+instance Outputable instr
+ => Outputable (InstrSR instr) where
+
+ ppr (Instr realInstr)
+ = ppr realInstr
+ ppr (SPILL reg slot)
+ = hcat [
+ ptext (sLit "\tSPILL"),
+ char ' ',
+ ppr reg,
+ comma,
+ ptext (sLit "SLOT") <> parens (int slot)]
-instance Outputable LiveInstr where
- ppr (Instr instr Nothing)
+ ppr (RELOAD slot reg)
+ = hcat [
+ ptext (sLit "\tRELOAD"),
+ char ' ',
+ ptext (sLit "SLOT") <> parens (int slot),
+ comma,
+ ppr reg]
+
+instance Outputable instr
+ => Outputable (LiveInstr instr) where
+
+ ppr (LiveInstr instr Nothing)
= ppr instr
- ppr (Instr instr (Just live))
+ ppr (LiveInstr instr (Just live))
= ppr instr
$$ (nest 8
$ vcat
where pprRegs :: SDoc -> RegSet -> SDoc
pprRegs name regs
| isEmptyUniqSet regs = empty
- | otherwise = name <> (hcat $ punctuate space $ map (docToSDoc . pprUserReg) $ uniqSetToList regs)
-
+ | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs)
instance Outputable LiveInfo where
- ppr (LiveInfo static firstId liveOnEntry)
+ ppr (LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry)
= (vcat $ map ppr static)
- $$ text "# firstId = " <> ppr firstId
- $$ text "# liveOnEntry = " <> ppr liveOnEntry
+ $$ text "# firstId = " <> ppr firstId
+ $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
+ $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
+
-- | map a function across all the basic blocks in this code
--
mapBlockTop
- :: (LiveBasicBlock -> LiveBasicBlock)
- -> LiveCmmTop -> LiveCmmTop
+ :: (LiveBasicBlock instr -> LiveBasicBlock instr)
+ -> LiveCmmTop instr -> LiveCmmTop instr
mapBlockTop f cmm
= evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
--
mapBlockTopM
:: Monad m
- => (LiveBasicBlock -> m LiveBasicBlock)
- -> LiveCmmTop -> m LiveCmmTop
+ => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
+ -> LiveCmmTop instr -> m (LiveCmmTop instr)
mapBlockTopM _ cmm@(CmmData{})
= return cmm
-mapBlockTopM f (CmmProc header label params (ListGraph comps))
- = do comps' <- mapM (mapBlockCompM f) comps
- return $ CmmProc header label params (ListGraph comps')
+mapBlockTopM f (CmmProc header label sccs)
+ = do sccs' <- mapM (mapSCCM f) sccs
+ return $ CmmProc header label sccs'
-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'
+mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
+mapSCCM f (AcyclicSCC x)
+ = do x' <- f x
+ return $ AcyclicSCC x'
+
+mapSCCM f (CyclicSCC xs)
+ = do xs' <- mapM f xs
+ return $ CyclicSCC xs'
-- map a function across all the basic blocks in this code
mapGenBlockTopM _ cmm@(CmmData{})
= return cmm
-mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
+mapGenBlockTopM f (CmmProc header label (ListGraph blocks))
= do blocks' <- mapM f blocks
- return $ CmmProc header label params (ListGraph blocks')
+ return $ CmmProc header label (ListGraph blocks')
-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
-- Slurping of conflicts and moves is wrapped up together so we don't have
-- to make two passes over the same code when we want to build the graph.
--
-slurpConflicts :: LiveCmmTop -> (Bag (UniqSet Reg), Bag (Reg, Reg))
+slurpConflicts
+ :: Instruction instr
+ => LiveCmmTop instr
+ -> (Bag (UniqSet Reg), Bag (Reg, Reg))
+
slurpConflicts live
= slurpCmm (emptyBag, emptyBag) live
where slurpCmm rs CmmData{} = rs
- slurpCmm rs (CmmProc info _ _ (ListGraph blocks))
- = foldl' (slurpComp info) rs blocks
+ slurpCmm rs (CmmProc info _ sccs)
+ = foldl' (slurpSCC info) rs sccs
+
+ slurpSCC info rs (AcyclicSCC b)
+ = slurpBlock info rs b
- slurpComp info rs (BasicBlock _ blocks)
- = foldl' (slurpBlock info) rs blocks
+ slurpSCC info rs (CyclicSCC bs)
+ = foldl' (slurpBlock info) rs bs
slurpBlock info rs (BasicBlock blockId instrs)
- | LiveInfo _ _ blockLive <- info
- , Just rsLiveEntry <- lookupBlockEnv blockLive blockId
- , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
+ | LiveInfo _ _ (Just blockLive) _ <- info
+ , Just rsLiveEntry <- mapLookup blockId blockLive
+ , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
= (consBag rsLiveEntry conflicts, moves)
| otherwise
- = panic "RegLiveness.slurpBlock: bad block"
+ = panic "Liveness.slurpConflicts: bad block"
slurpLIs rsLive (conflicts, moves) []
= (consBag rsLive conflicts, moves)
- slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis
+ slurpLIs rsLive rs (LiveInstr _ Nothing : lis)
+ = slurpLIs rsLive rs lis
- slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis)
+ slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr 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.
--
rsConflicts = unionUniqSets rsLiveNext rsOrphans
- in case isRegRegMove instr of
+ in case takeRegRegMoveInstr instr of
Just rr -> slurpLIs rsLiveNext
( consBag rsConflicts conflicts
, consBag rr moves) lis
-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
--
--
-slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg)
+slurpReloadCoalesce
+ :: forall instr. Instruction instr
+ => LiveCmmTop instr
+ -> 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
+ where
+ slurpCmm :: Bag (Reg, Reg)
+ -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
+ -> Bag (Reg, Reg)
+ slurpCmm cs CmmData{} = cs
+ slurpCmm cs (CmmProc _ _ sccs)
+ = slurpComp cs (flattenSCCs sccs)
+
+ slurpComp :: Bag (Reg, Reg)
+ -> [LiveBasicBlock instr]
+ -> Bag (Reg, Reg)
+ slurpComp cs blocks
+ = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM
in unionManyBags (cs : moveBags)
- slurpCompM (BasicBlock _ blocks)
+ slurpCompM :: [LiveBasicBlock instr]
+ -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
+ slurpCompM blocks
= do -- run the analysis once to record the mapping across jumps.
mapM_ (slurpBlock False) blocks
-- not worth the trouble.
mapM (slurpBlock True) blocks
+ slurpBlock :: Bool -> LiveBasicBlock instr
+ -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
slurpBlock propagate (BasicBlock blockId instrs)
= do -- grab the slot map for entry to this block
slotMap <- if propagate
return $ listToBag $ catMaybes mMoves
slurpLI :: UniqFM Reg -- current slotMap
- -> LiveInstr
+ -> LiveInstr instr
-> 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 _)
+ slurpLI slotMap li
-- remember what reg was stored into the slot
- | SPILL reg slot <- instr
- , slotMap' <- addToUFM slotMap slot reg
+ | LiveInstr (SPILL reg slot) _ <- li
+ , 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
+ | LiveInstr (RELOAD slot reg) _ <- li
= case lookupUFM slotMap slot of
Just reg2
| reg /= reg2 -> return (slotMap, Just (reg, reg2))
Nothing -> return (slotMap, Nothing)
-- if we hit a jump, remember the current slotMap
- | targets <- jumpDests instr []
+ | LiveInstr (Instr instr) _ <- li
+ , targets <- jumpDestsOfInstr instr
, not $ null targets
= do mapM_ (accSlotMap slotMap) targets
return (slotMap, Nothing)
-- | Strip away liveness information, yielding NatCmmTop
+stripLive
+ :: (Outputable instr, Instruction instr)
+ => LiveCmmTop instr
+ -> NatCmmTop instr
-stripLive :: LiveCmmTop -> NatCmmTop
stripLive live
= stripCmm live
where stripCmm (CmmData sec ds) = CmmData sec ds
- stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
- = CmmProc info label params
- (ListGraph $ concatMap stripComp comps)
+ stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs)
+ = let final_blocks = flattenSCCs sccs
+
+ -- make sure the block that was first in the input list
+ -- stays at the front of the output. This is the entry point
+ -- of the proc, and it needs to come first.
+ ((first':_), rest')
+ = partition ((== first_id) . blockId) final_blocks
+
+ in CmmProc info label
+ (ListGraph $ map stripLiveBlock $ first' : rest')
- stripComp (BasicBlock _ blocks) = map stripBlock blocks
- stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs)
- stripLI (Instr instr _) = instr
+ -- procs used for stg_split_markers don't contain any blocks, and have no first_id.
+ stripCmm (CmmProc (LiveInfo info Nothing _ _) label [])
+ = CmmProc info label (ListGraph [])
+ -- If the proc has blocks but we don't know what the first one was, then we're dead.
+ stripCmm proc
+ = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
--- | Make real spill instructions out of SPILL, RELOAD pseudos
-spillNatBlock :: NatBasicBlock -> NatBasicBlock
-spillNatBlock (BasicBlock i is)
+-- | Strip away liveness information from a basic block,
+-- and make real spill instructions out of SPILL, RELOAD pseudos along the way.
+
+stripLiveBlock
+ :: Instruction instr
+ => LiveBasicBlock instr
+ -> NatBasicBlock instr
+
+stripLiveBlock (BasicBlock i lis)
= BasicBlock i instrs'
+
where (instrs', _)
- = runState (spillNat [] is) 0
+ = runState (spillNat [] lis) 0
spillNat acc []
= return (reverse acc)
- spillNat acc (DELTA i : instrs)
- = do put i
- spillNat acc instrs
-
- spillNat acc (SPILL reg slot : instrs)
+ spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
= do delta <- get
spillNat (mkSpillInstr reg delta slot : acc) instrs
- spillNat acc (RELOAD slot reg : instrs)
+ spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
= do delta <- get
spillNat (mkLoadInstr reg delta slot : acc) instrs
- spillNat acc (instr : instrs)
+ spillNat acc (LiveInstr (Instr instr) _ : instrs)
+ | Just i <- takeDeltaInstr instr
+ = do put i
+ spillNat acc instrs
+
+ spillNat acc (LiveInstr (Instr instr) _ : instrs)
= spillNat (instr : acc) instrs
-- | Erase Delta instructions.
-eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
+eraseDeltasLive
+ :: Instruction instr
+ => LiveCmmTop instr
+ -> LiveCmmTop instr
+
eraseDeltasLive cmm
= mapBlockTop eraseBlock cmm
where
- isDelta (DELTA _) = True
- isDelta _ = False
-
eraseBlock (BasicBlock id lis)
= BasicBlock id
- $ filter (\(Instr i _) -> not $ isDelta i)
+ $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
$ lis
-- | Patch the registers in this code according to this register mapping.
-- also erase reg -> reg moves when the reg is the same.
-- also erase reg -> reg moves when the destination dies in this instr.
-
patchEraseLive
- :: (Reg -> Reg)
- -> LiveCmmTop -> LiveCmmTop
+ :: Instruction instr
+ => (Reg -> Reg)
+ -> LiveCmmTop instr -> LiveCmmTop instr
patchEraseLive patchF cmm
= patchCmm cmm
where
patchCmm cmm@CmmData{} = cmm
- patchCmm (CmmProc info label params (ListGraph comps))
- | LiveInfo static id blockMap <- info
- = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
- blockMap' = mapBlockEnv patchRegSet blockMap
+ patchCmm (CmmProc info label sccs)
+ | LiveInfo static id (Just blockMap) mLiveSlots <- info
+ = let
+ patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
+ blockMap' = mapMap patchRegSet blockMap
- info' = LiveInfo static id blockMap'
- in CmmProc info' label params $ ListGraph $ map patchComp comps
+ info' = LiveInfo static id (Just blockMap') mLiveSlots
+ in CmmProc info' label $ map patchSCC sccs
- patchComp (BasicBlock id blocks)
- = BasicBlock id $ map patchBlock blocks
+ | otherwise
+ = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
+
+ patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b)
+ patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs)
patchBlock (BasicBlock id lis)
= BasicBlock id $ patchInstrs lis
patchInstrs [] = []
patchInstrs (li : lis)
- | Instr i (Just live) <- li'
- , Just (r1, r2) <- isRegRegMove i
+ | LiveInstr i (Just live) <- li'
+ , Just (r1, r2) <- takeRegRegMoveInstr i
, eatMe r1 r2 live
= patchInstrs lis
-- | Patch registers in this LiveInstr, including the liveness information.
--
patchRegsLiveInstr
- :: (Reg -> Reg)
- -> LiveInstr -> LiveInstr
+ :: Instruction instr
+ => (Reg -> Reg)
+ -> LiveInstr instr -> LiveInstr instr
patchRegsLiveInstr patchF li
= case li of
- Instr instr Nothing
- -> Instr (patchRegs instr patchF) Nothing
+ LiveInstr instr Nothing
+ -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
- Instr instr (Just live)
- -> Instr
- (patchRegs instr patchF)
+ LiveInstr instr (Just live)
+ -> LiveInstr
+ (patchRegsOfInstr instr patchF)
(Just live
{ -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live
, liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
----------------------------------------------------------------------------------
--- Annotate code with register liveness information
---
-regLiveness
- :: NatCmmTop
- -> UniqSM LiveCmmTop
+--------------------------------------------------------------------------------
+-- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information
-regLiveness (CmmData i d)
- = returnUs $ CmmData i d
+natCmmTopToLive
+ :: Instruction instr
+ => NatCmmTop instr
+ -> LiveCmmTop instr
-regLiveness (CmmProc info lbl params (ListGraph []))
- = returnUs $ CmmProc
- (LiveInfo info Nothing emptyBlockEnv)
- lbl params (ListGraph [])
+natCmmTopToLive (CmmData i d)
+ = CmmData i d
-regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
- = let first_id = blockId first
- sccs = sccBlocks blocks
- (ann_sccs, block_live) = computeLiveness sccs
+natCmmTopToLive (CmmProc info lbl (ListGraph []))
+ = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl []
- liveBlocks
- = map (\scc -> case scc of
- AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [b]
- CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l bs
- CyclicSCC []
- -> panic "RegLiveness.regLiveness: no blocks in scc list")
- $ ann_sccs
+natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _)))
+ = let first_id = blockId first
+ sccs = sccBlocks blocks
+ sccsLive = map (fmap (\(BasicBlock l instrs) ->
+ BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
+ $ sccs
+
+ in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive
- in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live)
- lbl params (ListGraph liveBlocks)
+sccBlocks
+ :: Instruction instr
+ => [NatBasicBlock instr]
+ -> [SCC (NatBasicBlock instr)]
-sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
where
- getOutEdges :: [Instr] -> [BlockId]
- getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
+ getOutEdges :: Instruction instr => [instr] -> [BlockId]
+ getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
| block@(BasicBlock id instrs) <- blocks ]
--- -----------------------------------------------------------------------------
--- Computing liveness
+---------------------------------------------------------------------------------
+-- Annotate code with register liveness information
+--
+regLiveness
+ :: (Outputable instr, Instruction instr)
+ => LiveCmmTop instr
+ -> UniqSM (LiveCmmTop instr)
-computeLiveness
- :: [SCC NatBasicBlock]
- -> ([SCC LiveBasicBlock], -- instructions annotated with list of registers
- -- which are "dead after this instruction".
- BlockMap RegSet) -- blocks annontated with set of live registers
- -- on entry to the block.
+regLiveness (CmmData i d)
+ = returnUs $ CmmData i d
- -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
- -- control to earlier ones only. The SCCs returned are in the *opposite*
- -- order, which is exactly what we want for the next pass.
+regLiveness (CmmProc info lbl [])
+ | LiveInfo static mFirst _ _ <- info
+ = returnUs $ CmmProc
+ (LiveInfo static mFirst (Just mapEmpty) Map.empty)
+ lbl []
-computeLiveness sccs
- = livenessSCCs emptyBlockMap [] sccs
+regLiveness (CmmProc info lbl sccs)
+ | LiveInfo static mFirst _ liveSlotsOnEntry <- info
+ = let (ann_sccs, block_live) = computeLiveness sccs
+ in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
+ lbl ann_sccs
+
+
+-- -----------------------------------------------------------------------------
+-- | Check ordering of Blocks
+-- The computeLiveness function requires SCCs to be in reverse dependent order.
+-- If they're not the liveness information will be wrong, and we'll get a bad allocation.
+-- Better to check for this precondition explicitly or some other poor sucker will
+-- waste a day staring at bad assembly code..
+--
+checkIsReverseDependent
+ :: Instruction instr
+ => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on.
+ -> Maybe BlockId -- ^ BlockIds that fail the test (if any)
+
+checkIsReverseDependent sccs'
+ = go emptyUniqSet sccs'
+
+ where go _ []
+ = Nothing
+
+ go blocksSeen (AcyclicSCC block : sccs)
+ = let dests = slurpJumpDestsOfBlock block
+ blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
+ badDests = dests `minusUniqSet` blocksSeen'
+ in case uniqSetToList badDests of
+ [] -> go blocksSeen' sccs
+ bad : _ -> Just bad
+
+ go blocksSeen (CyclicSCC blocks : sccs)
+ = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
+ blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
+ badDests = dests `minusUniqSet` blocksSeen'
+ in case uniqSetToList badDests of
+ [] -> go blocksSeen' sccs
+ bad : _ -> Just bad
+
+ slurpJumpDestsOfBlock (BasicBlock _ instrs)
+ = unionManyUniqSets
+ $ map (mkUniqSet . jumpDestsOfInstr)
+ [ i | LiveInstr i _ <- instrs]
+
+
+-- | If we've compute liveness info for this code already we have to reverse
+-- the SCCs in each top to get them back to the right order so we can do it again.
+reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr
+reverseBlocksInTops top
+ = case top of
+ CmmData{} -> top
+ CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs)
+
+
+-- | Computing liveness
+--
+-- On entry, the SCCs must be in "reverse" order: later blocks may transfer
+-- control to earlier ones only, else `panic`.
+--
+-- The SCCs returned are in the *opposite* order, which is exactly what we
+-- want for the next pass.
+--
+computeLiveness
+ :: (Outputable instr, Instruction instr)
+ => [SCC (LiveBasicBlock instr)]
+ -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers
+ -- which are "dead after this instruction".
+ BlockMap RegSet) -- blocks annontated with set of live registers
+ -- on entry to the block.
+
+computeLiveness sccs
+ = case checkIsReverseDependent sccs of
+ Nothing -> livenessSCCs emptyBlockMap [] sccs
+ Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss"
+ (vcat [ text "SCCs aren't in reverse dependent order"
+ , text "bad blockId" <+> ppr bad
+ , ppr sccs])
livenessSCCs
- :: BlockMap RegSet
- -> [SCC LiveBasicBlock] -- accum
- -> [SCC NatBasicBlock]
- -> ([SCC LiveBasicBlock], BlockMap RegSet)
+ :: Instruction instr
+ => BlockMap RegSet
+ -> [SCC (LiveBasicBlock instr)] -- accum
+ -> [SCC (LiveBasicBlock instr)]
+ -> ( [SCC (LiveBasicBlock instr)]
+ , BlockMap RegSet)
-livenessSCCs blockmap done [] = (done, blockmap)
+livenessSCCs blockmap done []
+ = (done, blockmap)
livenessSCCs blockmap done (AcyclicSCC block : sccs)
= let (blockmap', block') = livenessBlock blockmap block
(a, panic "RegLiveness.livenessSCCs")
- linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
- -> (BlockMap RegSet, [LiveBasicBlock])
+ linearLiveness
+ :: Instruction instr
+ => BlockMap RegSet -> [LiveBasicBlock instr]
+ -> (BlockMap RegSet, [LiveBasicBlock instr])
+
linearLiveness = mapAccumL livenessBlock
-- probably the least efficient way to compare two
-- BlockMaps for equality.
equalBlockMaps a b
= a' == b'
- where a' = map f $ blockEnvToList a
- b' = map f $ blockEnvToList b
+ where a' = map f $ mapToList a
+ b' = map f $ mapToList b
f (key,elt) = (key, uniqSetToList elt)
-- | Annotate a basic block with register liveness information.
--
livenessBlock
- :: BlockMap RegSet
- -> NatBasicBlock
- -> (BlockMap RegSet, LiveBasicBlock)
+ :: Instruction instr
+ => BlockMap RegSet
+ -> LiveBasicBlock instr
+ -> (BlockMap RegSet, LiveBasicBlock instr)
livenessBlock blockmap (BasicBlock block_id instrs)
= let
(regsLiveOnEntry, instrs1)
= livenessBack emptyUniqSet blockmap [] (reverse instrs)
- blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry
+ blockmap' = mapInsert block_id regsLiveOnEntry blockmap
instrs2 = livenessForward regsLiveOnEntry instrs1
-- filling in when regs are born
livenessForward
- :: RegSet -- regs live on this instr
- -> [LiveInstr] -> [LiveInstr]
+ :: Instruction instr
+ => RegSet -- regs live on this instr
+ -> [LiveInstr instr] -> [LiveInstr instr]
livenessForward _ [] = []
-livenessForward rsLiveEntry (li@(Instr instr mLive) : lis)
+livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis)
| Nothing <- mLive
= li : livenessForward rsLiveEntry lis
| Just live <- mLive
- , RU _ written <- regUsage instr
+ , RU _ written <- regUsageOfInstr instr
= let
-- Regs that are written to but weren't live on entry to this instruction
-- are recorded as being born here.
`minusUniqSet` (liveDieRead live)
`minusUniqSet` (liveDieWrite live)
- in Instr instr (Just live { liveBorn = rsBorn })
+ in LiveInstr instr (Just live { liveBorn = rsBorn })
: livenessForward rsLiveNext lis
livenessForward _ _ = panic "RegLiveness.livenessForward: no match"
-- filling in when regs die, and what regs are live across each instruction
livenessBack
- :: RegSet -- regs live on this instr
+ :: Instruction instr
+ => RegSet -- regs live on this instr
-> BlockMap RegSet -- regs live on entry to other BBs
- -> [LiveInstr] -- instructions (accum)
- -> [Instr] -- instructions
- -> (RegSet, [LiveInstr])
+ -> [LiveInstr instr] -- instructions (accum)
+ -> [LiveInstr instr] -- instructions
+ -> (RegSet, [LiveInstr instr])
livenessBack liveregs _ done [] = (liveregs, done)
= let (liveregs', instr') = liveness1 liveregs blockmap instr
in livenessBack liveregs' blockmap (instr' : acc) instrs
+
-- don't bother tagging comments or deltas with liveness
-liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr)
-liveness1 liveregs _ (instr@COMMENT{})
- = (liveregs, Instr instr Nothing)
+liveness1
+ :: Instruction instr
+ => RegSet
+ -> BlockMap RegSet
+ -> LiveInstr instr
+ -> (RegSet, LiveInstr instr)
-liveness1 liveregs _ (instr@DELTA{})
- = (liveregs, Instr instr Nothing)
+liveness1 liveregs _ (LiveInstr instr _)
+ | isMetaInstr instr
+ = (liveregs, LiveInstr instr Nothing)
-liveness1 liveregs blockmap instr
+liveness1 liveregs blockmap (LiveInstr instr _)
- | not_a_branch
- = (liveregs1, Instr instr
+ | not_a_branch
+ = (liveregs1, LiveInstr instr
(Just $ Liveness
{ liveBorn = emptyUniqSet
, liveDieRead = mkUniqSet r_dying
, liveDieWrite = mkUniqSet w_dying }))
- | otherwise
- = (liveregs_br, Instr instr
+ | otherwise
+ = (liveregs_br, LiveInstr instr
(Just $ Liveness
{ liveBorn = emptyUniqSet
, liveDieRead = mkUniqSet r_dying_br
, liveDieWrite = mkUniqSet w_dying }))
- where
- RU read written = regUsage instr
+ where
+ RU read written = regUsageOfInstr instr
-- registers that were written here are dead going backwards.
-- registers that were read here are live going backwards.
-- union in the live regs from all the jump destinations of this
-- instruction.
- targets = jumpDests instr [] -- where we go from here
+ targets = jumpDestsOfInstr instr -- where we go from here
not_a_branch = null targets
targetLiveRegs target
- = case lookupBlockEnv blockmap target of
+ = case mapLookup target blockmap of
Just ra -> ra
Nothing -> emptyRegMap
live_branch_only)
-
-
projects / ghc-hetmet.git / blobdiff