NCG: Refactor LiveCmmTop to hold a list of SCCs instead of abusing ListGraph

diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
index 74eb0c2..a5d95a3 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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