From 85981a6fc4bb94af433b0b3655c26c5ec4dda1bd Mon Sep 17 00:00:00 2001 From: "Ben.Lippmeier@anu.edu.au" Date: Thu, 17 Sep 2009 06:03:32 +0000 Subject: [PATCH] NCG: Refactor LiveCmmTop to hold a list of SCCs instead of abusing ListGraph --- compiler/nativeGen/RegAlloc/Graph/Coalesce.hs | 8 +-- compiler/nativeGen/RegAlloc/Graph/SpillCost.hs | 10 ++-- compiler/nativeGen/RegAlloc/Linear/Main.hs | 10 +--- compiler/nativeGen/RegAlloc/Liveness.hs | 74 ++++++++++++------------ 4 files changed, 48 insertions(+), 54 deletions(-) diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 74eb0c2..a5d95a3 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -14,6 +14,7 @@ import Reg import Cmm import Bag +import Digraph import UniqFM import UniqSet import UniqSupply @@ -68,10 +69,9 @@ slurpJoinMovs slurpJoinMovs live = slurpCmm emptyBag live where - slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc _ _ _ (ListGraph blocks)) = foldl' slurpComp rs blocks - slurpComp rs (BasicBlock _ blocks) = foldl' slurpBlock rs blocks - slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs + slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) + slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs slurpLI rs (Instr _ Nothing) = rs slurpLI rs (Instr instr (Just live)) diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 58e9580..5932d31 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -23,11 +23,11 @@ import Reg import GraphBase - import BlockId import Cmm import UniqFM import UniqSet +import Digraph (flattenSCCs) import Outputable import State @@ -71,11 +71,9 @@ slurpSpillCostInfo cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () - countCmm (CmmProc info _ _ (ListGraph blocks)) - = mapM_ (countComp info) blocks - - countComp info (BasicBlock _ blocks) - = mapM_ (countBlock info) blocks + countCmm (CmmProc info _ _ sccs) + = mapM_ (countBlock info) + $ flattenSCCs sccs -- lookup the regs that are live on entry to this block in -- the info table from the CmmProc diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3eab785..229fd32 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -132,20 +132,16 @@ regAlloc (CmmData sec d) ( CmmData sec d , Nothing ) -regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) +regAlloc (CmmProc (LiveInfo info _ _) lbl params []) = return ( CmmProc info lbl params (ListGraph []) , Nothing ) -regAlloc (CmmProc static lbl params (ListGraph comps)) +regAlloc (CmmProc static lbl params sccs) | LiveInfo info (Just first_id) (Just block_live) <- static = do -- do register allocation on each component. (final_blocks, stats) - <- linearRegAlloc first_id block_live - $ map (\b -> case b of - BasicBlock _ [b] -> AcyclicSCC b - BasicBlock _ bs -> CyclicSCC bs) - $ comps + <- linearRegAlloc first_id block_live sccs -- make sure the block that was first in the input list -- stays at the front of the output diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 94277f6..e4481b5 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -70,10 +70,8 @@ type LiveCmmTop instr = 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 @@ -175,15 +173,25 @@ mapBlockTopM 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 @@ -221,11 +229,14 @@ 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 _ _ (Just blockLive) <- info @@ -300,14 +311,14 @@ slurpReloadCoalesce live = 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 @@ -392,12 +403,10 @@ stripLive live = 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. @@ -463,21 +472,20 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label params (ListGraph comps)) + 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 (Just blockMap') - in CmmProc info' label params $ ListGraph $ map patchComp comps + 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 @@ -578,23 +586,15 @@ regLiveness (CmmData i d) regLiveness (CmmProc info lbl params (ListGraph [])) = returnUs $ CmmProc (LiveInfo info Nothing (Just emptyBlockEnv)) - lbl params (ListGraph []) + 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) (Just block_live)) - lbl params (ListGraph liveBlocks) + lbl params ann_sccs sccBlocks -- 1.7.10.4