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

4 files changed, 48 insertions, 54 deletions

diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
index 74eb0c2f55..a5d95a3adf 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 58e9580338..5932d3100d 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 3eab7856ab..229fd32f57 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 94277f6309..e4481b59cd 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