= GenCmmTop
CmmStatic
LiveInfo
- (ListGraph (GenBasicBlock (LiveInstr instr)))
- -- the "instructions" here are actually more blocks,
- -- single blocks are acyclic
- -- multiple blocks are taken to be cyclic.
+ [SCC (LiveBasicBlock instr)]
+
-- | An instruction with liveness information.
data LiveInstr instr
-- | 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
-- | A basic block with liveness information.
type LiveBasicBlock 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 params sccs)
+ = do sccs' <- mapM (mapSCCM f) sccs
+ return $ CmmProc header label params sccs'
+
+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'
+{-
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
= 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
+ | LiveInfo _ _ (Just blockLive) <- info
, Just rsLiveEntry <- lookupBlockEnv blockLive blockId
, (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
= (consBag rsLiveEntry conflicts, moves)
= slurpCmm emptyBag live
where slurpCmm cs CmmData{} = cs
- slurpCmm cs (CmmProc _ _ _ (ListGraph blocks))
- = foldl' slurpComp cs blocks
+ slurpCmm cs (CmmProc _ _ _ sccs)
+ = slurpComp cs (flattenSCCs sccs)
- slurpComp cs comp
- = let (moveBags, _) = runState (slurpCompM comp) emptyUFM
+ slurpComp cs blocks
+ = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM
in unionManyBags (cs : moveBags)
- slurpCompM (BasicBlock _ blocks)
+ slurpCompM blocks
= do -- run the analysis once to record the mapping across jumps.
mapM_ (slurpBlock False) blocks
= stripCmm live
where stripCmm (CmmData sec ds) = CmmData sec ds
- stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
+ stripCmm (CmmProc (LiveInfo info _ _) label params sccs)
= CmmProc info label params
- (ListGraph $ concatMap stripComp comps)
-
- stripComp (BasicBlock _ blocks) = map stripLiveBlock blocks
-
+ (ListGraph $ map stripLiveBlock $ flattenSCCs sccs)
+
-- | Strip away liveness information from a basic block,
-- and make real spill instructions out of SPILL, RELOAD pseudos along the way.
where
patchCmm cmm@CmmData{} = cmm
- patchCmm (CmmProc info label params (ListGraph comps))
- | LiveInfo static id blockMap <- info
+ patchCmm (CmmProc info label params sccs)
+ | LiveInfo static id (Just blockMap) <- info
= let
patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
blockMap' = mapBlockEnv patchRegSet blockMap
- info' = LiveInfo static id blockMap'
- in CmmProc info' label params $ ListGraph $ map patchComp comps
+ info' = LiveInfo static id (Just blockMap')
+ in CmmProc info' label params $ map patchSCC sccs
+
+ | otherwise
+ = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
- patchComp (BasicBlock id blocks)
- = BasicBlock id $ map patchBlock blocks
+ patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b)
+ patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs)
patchBlock (BasicBlock id lis)
= BasicBlock id $ patchInstrs lis
-> RELOAD slot (patchF reg)
+--------------------------------------------------------------------------------
+-- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information
+{-
+natCmmTopToLive
+ :: NatCmmTop instr
+ -> LiveCmmTop instr
+
+natCmmTopToLive cmm@(CmmData _ _)
+ = cmm
+
+natCmmTopToLive (CmmProc info lbl params (ListGraph []))
+ = CmmProc (LiveInfo info Nothing emptyBlockEnv)
+ lbl params (ListGraph []))
+
+natCmmTopToLive (CmmProc info lbl params (ListGraph blocks))
+ = let first_id = blockId first
+ sccs = sccBlocks blocks
+
+ 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) ???
+-}
+
---------------------------------------------------------------------------------
-- Annotate code with register liveness information
--
regLiveness (CmmProc info lbl params (ListGraph []))
= returnUs $ CmmProc
- (LiveInfo info Nothing emptyBlockEnv)
- lbl params (ListGraph [])
+ (LiveInfo info Nothing (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
- 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
-
- in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live)
- lbl params (ListGraph liveBlocks)
+ in returnUs $ CmmProc (LiveInfo info (Just first_id) (Just block_live))
+ lbl params ann_sccs
sccBlocks