X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocColor.hs;h=45e51b927fd44eb2665c0097b33140da44d5916a;hb=f8c52d7fde2d7408b4f734251c373f8d3e2c558e;hp=d5ec7af8ebd84d90e780fa46f84fd91e7d9ece94;hpb=f8c572418898d4c0e703f6d67510c9c37b51cc6e;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index d5ec7af..45e51b9 100644
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -1,17 +1,10 @@
 -- | Graph coloring register allocator.
 --
 -- TODO:
---	Live range splitting:
---		At the moment regs that are spilled are spilled for all time, even though
---		we might be able to allocate them a hardreg in different parts of the code.
---
---	As we're aggressively coalescing before register allocation proper we're not currently
---	using the coalescence information present in the graph.
---
 --	The function that choosing the potential spills could be a bit cleverer.
---
 --	Colors in graphviz graphs could be nicer.
 --
+{-# OPTIONS -fno-warn-missing-signatures #-}
 
 module RegAllocColor ( 
 	regAlloc,
@@ -27,7 +20,6 @@ import RegSpillClean
 import RegAllocStats
 import MachRegs
 import MachInstrs
-import RegCoalesce
 import PprMach
 
 import UniqSupply
@@ -61,7 +53,7 @@ regAlloc
 		
 regAlloc dump regsFree slotsFree code
  = do
- 	(code_final, debug_codeGraphs, graph_final)
+ 	(code_final, debug_codeGraphs, _)
 		<- regAlloc_spin dump 0 trivColorable regsFree slotsFree [] code
 	
 	return	( code_final
@@ -79,11 +71,20 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		$$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
 
  	-- build a conflict graph from the code.
-	graph		<- buildGraph code
+	graph		<- {-# SCC "BuildGraph" #-} buildGraph code
+
+	-- VERY IMPORTANT:
+	--	We really do want the graph to be fully evaluated _before_ we start coloring.
+	--	If we don't do this now then when the call to Color.colorGraph forces bits of it,
+	--	the heap will be filled with half evaluated pieces of graph and zillions of apply thunks.
+	--
+	seqGraph graph `seq` return ()
+
 
 	-- build a map of how many instructions each reg lives for.
 	--	this is lazy, it won't be computed unless we need to spill
-	let fmLife	= plusUFMs_C (\(r1, l1) (r2, l2) -> (r1, l1 + l2))
+
+	let fmLife	= {-# SCC "LifetimeCount" #-} plusUFMs_C (\(r1, l1) (_, l2) -> (r1, l1 + l2))
 			$ map lifetimeCount code
 
 	-- record startup state
@@ -100,14 +101,22 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 	let spill	= chooseSpill_maxLife fmLife
 	
 	-- try and color the graph 
-	let (graph_colored, rsSpill)	
-			= Color.colorGraph regsFree triv spill graph
+	let (graph_colored, rsSpill, rmCoalesce)
+			= {-# SCC "ColorGraph" #-} Color.colorGraph regsFree triv spill graph
+
+	-- rewrite regs in the code that have been coalesced
+	let patchF reg	= case lookupUFM rmCoalesce reg of
+				Just reg'	-> reg'
+				Nothing		-> reg
+	let code_coalesced
+			= map (patchEraseLive patchF) code
+
 
 	-- see if we've found a coloring
 	if isEmptyUniqSet rsSpill
 	 then do
 		-- patch the registers using the info in the graph
-	 	let code_patched	= map (patchRegsFromGraph graph_colored) code
+	 	let code_patched	= map (patchRegsFromGraph graph_colored) code_coalesced
 
 		-- clean out unneeded SPILL/RELOADs
 		let code_spillclean	= map cleanSpills code_patched
@@ -115,7 +124,7 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		-- strip off liveness information
 		let code_nat		= map stripLive code_patched
 
-		-- rewrite SPILL/REALOAD pseudos into real instructions
+		-- rewrite SPILL/RELOAD pseudos into real instructions
 		let spillNatTop		= mapGenBlockTop spillNatBlock
 		let code_final		= map spillNatTop code_nat
 		
@@ -123,22 +132,29 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		let stat		=
 			RegAllocStatsColored
 			{ raGraph	= graph_colored
+			, raCoalesced	= rmCoalesce
 			, raPatched	= code_patched
 			, raSpillClean	= code_spillclean
 			, raFinal	= code_final
-			, raSRMs	= foldl addSRM (0, 0, 0) $ map countSRMs code_spillclean }
+			, raSRMs	= foldl' addSRM (0, 0, 0) $ map countSRMs code_spillclean }
 
-		return	( code_final
-			, if dump
-				then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+
+		let statList =
+			if dump	then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
 				else []
+
+		-- space leak avoidance
+		seqList statList `seq` return ()
+
+		return	( code_final
+			, statList
 			, graph_colored)
 
 	 else do
 	 	-- spill the uncolored regs
 		(code_spilled, slotsFree', spillStats)
-			<- regSpill code slotsFree rsSpill
-			
+			<- regSpill code_coalesced slotsFree rsSpill
+
 		-- recalculate liveness
 		let code_nat	= map stripLive code_spilled
 		code_relive	<- mapM regLiveness code_nat
@@ -147,15 +163,21 @@ regAlloc_spin dump (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs c
 		let stat	=
 			RegAllocStatsSpill
 			{ raGraph	= graph_colored
+			, raCoalesced	= rmCoalesce
 			, raSpillStats	= spillStats
 			, raLifetimes	= fmLife
 			, raSpilled	= code_spilled }
 			    	
-		-- try again
-		regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
-			(if dump
+		let statList =
+			if dump
 				then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
-				else [])
+				else []
+
+		-- space leak avoidance
+		seqList statList `seq` return ()
+
+		regAlloc_spin dump (spinCount + 1) triv regsFree slotsFree'
+			statList
 			code_relive
 
  
@@ -207,16 +229,20 @@ buildGraph
 	
 buildGraph code
  = do
- 	-- Add the reg-reg conflicts to the graph
-	let conflictSets	= unionManyBags (map slurpConflicts code)
-	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictSets
+	-- Slurp out the conflicts and reg->reg moves from this code
+	let (conflictList, moveList) =
+		unzip $ map slurpConflicts code
 
+	let conflictBag		= unionManyBags conflictList
+	let moveBag		= unionManyBags moveList
+
+ 	-- Add the reg-reg conflicts to the graph
+	let graph_conflict	= foldrBag graphAddConflictSet Color.initGraph conflictBag
 
 	-- Add the coalescences edges to the graph.
-	let coalesce		= unionManyBags (map slurpJoinMovs code)
-	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict coalesce
+	let graph_coalesce	= foldrBag graphAddCoalesce graph_conflict moveBag
 			
-	return	$ graph_coalesce
+	return	graph_coalesce
 
 
 -- | Add some conflict edges to the graph.
@@ -250,10 +276,10 @@ graphAddCoalesce
 	-> Color.Graph Reg RegClass Reg
 	
 graphAddCoalesce (r1, r2) graph
-	| RealReg regno <- r1
+	| RealReg _ <- r1
 	= Color.addPreference (regWithClass r2) r1 graph
 	
-	| RealReg regno <- r2
+	| RealReg _ <- r2
 	= Color.addPreference (regWithClass r1) r2 graph
 	
 	| otherwise
@@ -286,12 +312,70 @@ patchRegsFromGraph graph code
 		= pprPanic "patchRegsFromGraph: register mapping failed." 
 			(  text "There is no node in the graph for register " <> ppr reg
 			$$ ppr code
-			$$ Color.dotGraph (\x -> text "white") trivColorable graph)
+			$$ Color.dotGraph (\_ -> text "white") trivColorable graph)
 	
    in	patchEraseLive patchF code
    
 
 plusUFMs_C  :: (elt -> elt -> elt) -> [UniqFM elt] -> UniqFM elt
 plusUFMs_C f maps
-	= foldl (plusUFM_C f) emptyUFM maps
-	
+	= foldl' (plusUFM_C f) emptyUFM maps
+
+
+-----
+-- for when laziness just isn't what you wanted...
+--
+seqGraph :: Color.Graph Reg RegClass Reg -> ()
+seqGraph graph		= seqNodes (eltsUFM (Color.graphMap graph))
+
+seqNodes :: [Color.Node Reg RegClass Reg] -> ()
+seqNodes ns
+ = case ns of
+ 	[]		-> ()
+	(n : ns)	-> seqNode n `seq` seqNodes ns
+
+seqNode :: Color.Node Reg RegClass Reg -> ()
+seqNode node
+	=     seqReg      (Color.nodeId node)
+	`seq` seqRegClass (Color.nodeClass node)
+	`seq` seqMaybeReg (Color.nodeColor node)
+	`seq` (seqRegList (uniqSetToList (Color.nodeConflicts node)))
+	`seq` (seqRegList (uniqSetToList (Color.nodeExclusions node)))
+	`seq` (seqRegList (Color.nodePreference node))
+	`seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node)))
+
+seqReg :: Reg -> ()
+seqReg reg
+ = case reg of
+ 	RealReg _	-> ()
+	VirtualRegI _	-> ()
+	VirtualRegHi _	-> ()
+	VirtualRegF _	-> ()
+	VirtualRegD _	-> ()
+
+seqRegClass :: RegClass -> ()
+seqRegClass c
+ = case c of
+ 	RcInteger	-> ()
+	RcFloat		-> ()
+	RcDouble	-> ()
+
+seqMaybeReg :: Maybe Reg -> ()
+seqMaybeReg mr
+ = case mr of
+ 	Nothing		-> ()
+	Just r		-> seqReg r
+
+seqRegList :: [Reg] -> ()
+seqRegList rs
+ = case rs of
+ 	[]		-> ()
+	(r : rs)	-> seqReg r `seq` seqRegList rs
+
+seqList :: [a] -> ()
+seqList ls
+ = case ls of
+ 	[]		-> ()
+	(r : rs)	-> r `seq` seqList rs
+
+