RegMap, emptyRegMap,
BlockMap, emptyBlockMap,
LiveCmmTop,
+ InstrSR (..),
LiveInstr (..),
Liveness (..),
LiveInfo (..),
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
- regLiveness
-
+ reverseBlocksInTops,
+ regLiveness,
+ natCmmTopToLive
) where
[SCC (LiveBasicBlock instr)]
--- | An instruction with liveness information.
-data LiveInstr instr
- = Instr instr (Maybe Liveness)
+-- | 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
+ | 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
+ = LiveInstr (InstrSR instr) (Maybe Liveness)
-- | Liveness information.
-- The regs which die are ones which are no longer live in the *next* instruction
= GenBasicBlock (LiveInstr instr)
-instance Outputable instr
- => Outputable (LiveInstr instr) where
+instance Outputable instr
+ => Outputable (InstrSR instr) where
+
+ ppr (Instr realInstr)
+ = ppr realInstr
+
ppr (SPILL reg slot)
= hcat [
ptext (sLit "\tSPILL"),
comma,
ppr reg]
- ppr (Instr instr Nothing)
+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
= do xs' <- mapM f xs
return $ CyclicSCC xs'
-{-
-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
slurpLIs rsLive (conflicts, moves) []
= (consBag rsLive conflicts, moves)
- slurpLIs rsLive rs (Instr _ Nothing : lis)
+ slurpLIs rsLive rs (LiveInstr _ Nothing : lis)
= slurpLIs rsLive rs lis
-
- -- we're not expecting to be slurping conflicts from spilled code
- slurpLIs _ _ (SPILL _ _ : _)
- = panic "Liveness.slurpConflicts: unexpected SPILL"
-
- slurpLIs _ _ (RELOAD _ _ : _)
- = panic "Liveness.slurpConflicts: unexpected RELOAD"
- 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.
slurpLI slotMap li
-- remember what reg was stored into the slot
- | SPILL reg slot <- li
- , 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 <- li
+ | 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
- | Instr instr _ <- li
- , targets <- jumpDestsOfInstr 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
- :: Instruction instr
+ :: (Outputable instr, Instruction instr)
=> LiveCmmTop instr
-> NatCmmTop instr
= stripCmm live
where stripCmm (CmmData sec ds) = CmmData sec ds
- stripCmm (CmmProc (LiveInfo info _ _) label params sccs)
- = CmmProc info label params
- (ListGraph $ map stripLiveBlock $ flattenSCCs sccs)
-
+
+ stripCmm (CmmProc (LiveInfo info (Just first_id) _) label params 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 params
+ (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 [])
+
+ -- 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.
spillNat acc []
= return (reverse acc)
- 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 instr _ : instrs)
+ spillNat acc (LiveInstr (Instr instr) _ : instrs)
| Just i <- takeDeltaInstr instr
= do put i
spillNat acc instrs
- spillNat acc (Instr instr _ : instrs)
+ spillNat acc (LiveInstr (Instr instr) _ : instrs)
= spillNat (instr : acc) instrs
where
eraseBlock (BasicBlock id lis)
= BasicBlock id
- $ filter (\(Instr i _) -> not $ isJust $ takeDeltaInstr i)
+ $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
$ lis
patchInstrs [] = []
patchInstrs (li : lis)
- | Instr i (Just live) <- li'
+ | LiveInstr i (Just live) <- li'
, Just (r1, r2) <- takeRegRegMoveInstr i
, eatMe r1 r2 live
= patchInstrs lis
patchRegsLiveInstr patchF li
= case li of
- Instr instr Nothing
- -> Instr (patchRegsOfInstr instr patchF) Nothing
+ LiveInstr instr Nothing
+ -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
- Instr instr (Just live)
- -> Instr
+ 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
, liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live
, liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live })
- SPILL reg slot
- -> SPILL (patchF reg) slot
-
- RELOAD slot reg
- -> RELOAD slot (patchF reg)
-
--------------------------------------------------------------------------------
-- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information
-{-
+
natCmmTopToLive
- :: NatCmmTop instr
+ :: Instruction instr
+ => NatCmmTop instr
-> LiveCmmTop instr
-natCmmTopToLive cmm@(CmmData _ _)
- = cmm
+natCmmTopToLive (CmmData i d)
+ = CmmData i d
natCmmTopToLive (CmmProc info lbl params (ListGraph []))
- = CmmProc (LiveInfo info Nothing emptyBlockEnv)
- lbl params (ListGraph []))
+ = CmmProc (LiveInfo info Nothing Nothing)
+ lbl params []
-natCmmTopToLive (CmmProc info lbl params (ListGraph blocks))
- = let first_id = blockId first
- sccs = sccBlocks blocks
+natCmmTopToLive (CmmProc info lbl params (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
- liveBlocks
- = map (\scc -> case scc of
- AcyclicSCC b@(BasicBlock l _) -> BasicBlock l [cmmBlockToLive b]
- CyclicSCC bs@(BasicBlock l _ : _) -> BasicBlock l (map cmmBlockToLive bs)
- CyclicSCC []
- -> panic "RegLiveNess.natCmmTopToLive: no blocks in scc list")
- sccs
- in CmmProc (LiveInfo info (Just first_id) ???
--}
+sccBlocks
+ :: Instruction instr
+ => [NatBasicBlock instr]
+ -> [SCC (NatBasicBlock instr)]
+
+sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
+ where
+ getOutEdges :: Instruction instr => [instr] -> [BlockId]
+ getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
+
+ graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
+ | block@(BasicBlock id instrs) <- blocks ]
+
---------------------------------------------------------------------------------
-- Annotate code with register liveness information
--
regLiveness
- :: Instruction instr
- => NatCmmTop instr
+ :: (Outputable instr, Instruction instr)
+ => LiveCmmTop instr
-> UniqSM (LiveCmmTop instr)
regLiveness (CmmData i d)
= returnUs $ CmmData i d
-regLiveness (CmmProc info lbl params (ListGraph []))
+regLiveness (CmmProc info lbl params [])
+ | LiveInfo static mFirst _ <- info
= returnUs $ CmmProc
- (LiveInfo info Nothing (Just emptyBlockEnv))
+ (LiveInfo static mFirst (Just emptyBlockEnv))
lbl params []
-regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
- = let first_id = blockId first
- sccs = sccBlocks blocks
- (ann_sccs, block_live) = computeLiveness sccs
+regLiveness (CmmProc info lbl params sccs)
+ | LiveInfo static mFirst _ <- info
+ = let (ann_sccs, block_live) = computeLiveness sccs
- in returnUs $ CmmProc (LiveInfo info (Just first_id) (Just block_live))
+ in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live))
lbl params ann_sccs
-sccBlocks
+-- -----------------------------------------------------------------------------
+-- | 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
- => [NatBasicBlock instr]
- -> [SCC (NatBasicBlock instr)]
-
-sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
- where
- getOutEdges :: Instruction instr => [instr] -> [BlockId]
- getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
+ => [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'
- graph = [ (block, getUnique id, map getUnique (getOutEdges instrs))
- | block@(BasicBlock id instrs) <- blocks ]
+ 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]
--- -----------------------------------------------------------------------------
--- Computing liveness
+-- | 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 params sccs -> CmmProc info lbl params (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
- => [SCC (NatBasicBlock 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
=> BlockMap RegSet
-> [SCC (LiveBasicBlock instr)] -- accum
- -> [SCC (NatBasicBlock instr)]
+ -> [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
linearLiveness
:: Instruction instr
- => BlockMap RegSet -> [NatBasicBlock instr]
+ => BlockMap RegSet -> [LiveBasicBlock instr]
-> (BlockMap RegSet, [LiveBasicBlock instr])
linearLiveness = mapAccumL livenessBlock
livenessBlock
:: Instruction instr
=> BlockMap RegSet
- -> NatBasicBlock instr
+ -> LiveBasicBlock instr
-> (BlockMap RegSet, LiveBasicBlock instr)
livenessBlock blockmap (BasicBlock block_id instrs)
-> [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
`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"
=> RegSet -- regs live on this instr
-> BlockMap RegSet -- regs live on entry to other BBs
-> [LiveInstr instr] -- instructions (accum)
- -> [instr] -- instructions
+ -> [LiveInstr instr] -- instructions
-> (RegSet, [LiveInstr instr])
livenessBack liveregs _ done [] = (liveregs, done)
:: Instruction instr
=> RegSet
-> BlockMap RegSet
- -> instr
+ -> LiveInstr instr
-> (RegSet, LiveInstr instr)
-liveness1 liveregs _ instr
+liveness1 liveregs _ (LiveInstr instr _)
| isMetaInstr instr
- = (liveregs, Instr instr Nothing)
+ = (liveregs, LiveInstr instr Nothing)
-liveness1 liveregs blockmap instr
+liveness1 liveregs blockmap (LiveInstr instr _)
| not_a_branch
- = (liveregs1, Instr instr
+ = (liveregs1, LiveInstr instr
(Just $ Liveness
{ liveBorn = emptyUniqSet
, liveDieRead = mkUniqSet r_dying
, liveDieWrite = mkUniqSet w_dying }))
| otherwise
- = (liveregs_br, Instr instr
+ = (liveregs_br, LiveInstr instr
(Just $ Liveness
{ liveBorn = emptyUniqSet
, liveDieRead = mkUniqSet r_dying_br
projects / ghc-hetmet.git / blobdiff