LiveInfo (..),
LiveBasicBlock,
- mapBlockTop, mapBlockTopM,
+ mapBlockTop, mapBlockTopM, mapSCCM,
mapGenBlockTop, mapGenBlockTopM,
stripLive,
stripLiveBlock,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
+ reverseBlocksInTops,
regLiveness,
natCmmTopToLive
) where
-
-
import Reg
import Instruction
import BlockId
-import Cmm hiding (RegSet)
-import PprCmm()
+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 instr
-- | An instruction with liveness information.
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
- (Maybe (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 instr
| 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)
mapBlockTopM _ cmm@(CmmData{})
= return cmm
-mapBlockTopM f (CmmProc header label params sccs)
+mapBlockTopM f (CmmProc header label sccs)
= do sccs' <- mapM (mapSCCM f) sccs
- return $ CmmProc header label params sccs'
+ return $ CmmProc header label sccs'
mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
mapSCCM f (AcyclicSCC x)
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.
= slurpCmm (emptyBag, emptyBag) live
where slurpCmm rs CmmData{} = rs
- slurpCmm rs (CmmProc info _ _ sccs)
+ slurpCmm rs (CmmProc info _ sccs)
= foldl' (slurpSCC info) rs sccs
slurpSCC info rs (AcyclicSCC b)
= foldl' (slurpBlock info) rs bs
slurpBlock info rs (BasicBlock blockId instrs)
- | LiveInfo _ _ (Just 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
--
--
slurpReloadCoalesce
- :: Instruction instr
+ :: forall instr. Instruction instr
=> LiveCmmTop instr
-> Bag (Reg, Reg)
slurpReloadCoalesce live
= slurpCmm emptyBag live
- where slurpCmm cs CmmData{} = cs
- slurpCmm cs (CmmProc _ _ _ sccs)
+ 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 :: [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
(_, mMoves) <- mapAccumLM slurpLI slotMap instrs
return $ listToBag $ catMaybes mMoves
- slurpLI :: Instruction instr
- => UniqFM Reg -- current slotMap
+ slurpLI :: UniqFM Reg -- current slotMap
-> LiveInstr instr
-> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg]
-- for tracking slotMaps across jumps
= stripCmm live
where stripCmm (CmmData sec ds) = CmmData sec ds
-
- stripCmm (CmmProc (LiveInfo info (Just first_id) _) label params sccs)
+ 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
((first':_), rest')
= partition ((== first_id) . blockId) final_blocks
- in CmmProc info label params
+ in CmmProc info label
(ListGraph $ map stripLiveBlock $ first' : rest')
-- procs used for stg_split_markers don't contain any blocks, and have no first_id.
- stripCmm (CmmProc (LiveInfo info Nothing _) label params [])
- = CmmProc info label params (ListGraph [])
+ 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)
-
+
-- | Strip away liveness information from a basic block,
-- and make real spill instructions out of SPILL, RELOAD pseudos along the way.
-- | 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
:: Instruction instr
=> (Reg -> Reg)
where
patchCmm cmm@CmmData{} = cmm
- patchCmm (CmmProc info label params sccs)
- | LiveInfo static id (Just blockMap) <- info
+ patchCmm (CmmProc info label sccs)
+ | LiveInfo static id (Just blockMap) mLiveSlots <- info
= let
patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
- blockMap' = mapBlockEnv patchRegSet blockMap
+ blockMap' = mapMap patchRegSet blockMap
- info' = LiveInfo static id (Just blockMap')
- in CmmProc info' label params $ map patchSCC sccs
+ info' = LiveInfo static id (Just blockMap') mLiveSlots
+ in CmmProc info' label $ map patchSCC sccs
| otherwise
= panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
natCmmTopToLive (CmmData i d)
= CmmData i d
-natCmmTopToLive (CmmProc info lbl params (ListGraph []))
- = CmmProc (LiveInfo info Nothing Nothing)
- lbl params []
+natCmmTopToLive (CmmProc info lbl (ListGraph []))
+ = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl []
-natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _)))
+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)
- lbl params sccsLive
+ in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive
sccBlocks
-- Annotate code with register liveness information
--
regLiveness
- :: Instruction instr
+ :: (Outputable instr, Instruction instr)
=> LiveCmmTop instr
-> UniqSM (LiveCmmTop instr)
regLiveness (CmmData i d)
= returnUs $ CmmData i d
-regLiveness (CmmProc info lbl params [])
- | LiveInfo static mFirst _ <- info
+regLiveness (CmmProc info lbl [])
+ | LiveInfo static mFirst _ _ <- info
= returnUs $ CmmProc
- (LiveInfo static mFirst (Just emptyBlockEnv))
- lbl params []
+ (LiveInfo static mFirst (Just mapEmpty) Map.empty)
+ lbl []
-regLiveness (CmmProc info lbl params sccs)
- | LiveInfo static mFirst _ <- info
+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))
- lbl params ann_sccs
-
+ in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
+ lbl ann_sccs
-- -----------------------------------------------------------------------------
--- Computing liveness
+-- | 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
- :: Instruction instr
+ :: (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.
-
- -- 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.
computeLiveness sccs
- = livenessSCCs emptyBlockMap [] 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
:: Instruction instr
-- 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)
= let
(regsLiveOnEntry, instrs1)
= livenessBack emptyUniqSet blockmap [] (reverse instrs)
- blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry
+ blockmap' = mapInsert block_id regsLiveOnEntry blockmap
instrs2 = livenessForward regsLiveOnEntry instrs1
not_a_branch = null targets
targetLiveRegs target
- = case lookupBlockEnv blockmap target of
+ = case mapLookup target blockmap of
Just ra -> ra
Nothing -> emptyRegMap
projects / ghc-hetmet.git / blobdiff