From: Ben.Lippmeier@anu.edu.au <unknown>
Date: Tue, 11 Sep 2007 15:12:11 +0000 (+0000)
Subject: Don't try and coalesce nodes with themselves
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9d2b0ebb2a6c43d6cd4f27e763897cc06592f5a0

Don't try and coalesce nodes with themselves
---

diff --git a/compiler/nativeGen/GraphColor.hs b/compiler/nativeGen/GraphColor.hs
index dfb2d17..307803a 100644
--- a/compiler/nativeGen/GraphColor.hs
+++ b/compiler/nativeGen/GraphColor.hs
@@ -154,7 +154,10 @@ colorScan_spin iterative triv spill graph
 			$ graph
 
 	, ksTrivFound	<- map nodeId nsTrivFound
-	, graph3	<- foldr delNode graph ksTrivFound
+	, graph3	<- foldr (\k g -> let Just g' = delNode k g
+	   				  in  g')
+				graph ksTrivFound
+
 	= colorScan_spin iterative triv spill graph3
 		(ksTrivFound ++ ksTriv)
 		ksSpill
@@ -204,8 +207,8 @@ colorScan_spin iterative triv spill graph
 colorScan_spill iterative triv spill graph
 	ksTriv ksSpill kksCoalesce
 
- = let	kSpill	= spill graph
- 	graph'	= delNode kSpill graph
+ = let	kSpill		= spill graph
+ 	Just graph'	= delNode kSpill graph
    in	colorScan_spin iterative triv spill graph'
    		ksTriv (kSpill : ksSpill) kksCoalesce
 	
diff --git a/compiler/nativeGen/GraphOps.hs b/compiler/nativeGen/GraphOps.hs
index c494e63..414abe4 100644
--- a/compiler/nativeGen/GraphOps.hs
+++ b/compiler/nativeGen/GraphOps.hs
@@ -78,28 +78,28 @@ addNode k node graph
   	{ graphMap	= addToUFM map_coalesce k node}
 		
 
-
 -- | Delete a node and all its edges from the graph.
---	Throws an error if it's not there.
-delNode :: Uniquable k
-	=> k -> Graph k cls color -> Graph k cls color
+delNode :: (Uniquable k, Outputable k)
+	=> k -> Graph k cls color -> Maybe (Graph k cls color)
 
 delNode k graph
- = let	Just node	= lookupNode graph k
-
-	-- delete conflict edges from other nodes to this one.
-	graph1		= foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
+	| Just node	<- lookupNode graph k
+	= let	-- delete conflict edges from other nodes to this one.
+		graph1	= foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
 			$ uniqSetToList (nodeConflicts node)
 	
-	-- delete coalesce edge from other nodes to this one.
-	graph2		= foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
+		-- delete coalesce edge from other nodes to this one.
+		graph2	= foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
 			$ uniqSetToList (nodeCoalesce node)
 	
-	-- delete the node
-	graph3		= graphMapModify (\fm -> delFromUFM fm k) graph2
+		-- delete the node
+		graph3	= graphMapModify (\fm -> delFromUFM fm k) graph2
 	
-  in	graph3
+	  in	Just graph3
 		
+	| otherwise
+	= Nothing
+
 
 -- | Modify a node in the graph.
 --	returns Nothing if the node isn't present.
@@ -350,6 +350,9 @@ coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
 	| not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
 	= error "GraphOps.coalesceNodes: can't coalesce colored nodes."
 
+	| nodeId nMin == nodeId nMax
+	= error "GraphOps.coalesceNodes: can't coalesce the same node."
+
 	---
 	| otherwise
 	= let
@@ -387,12 +390,11 @@ coalesceNodes_check aggressive triv graph kMin kMax node
 
 	| otherwise
 	= let -- delete the old nodes from the graph and add the new one
-		graph'	= addNode kMin node
-			$ delNode kMin
-			$ delNode kMax
-			$ graph
+		Just graph1	= delNode kMax graph
+		Just graph2	= delNode kMin graph1
+		graph3		= addNode kMin node graph2
 
-	  in	(graph', Just (kMax, kMin))
+	  in	(graph3, Just (kMax, kMin))
 
 
 -- | Freeze a node
diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 5f8db17..b55d8c0 100644
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -283,7 +283,10 @@ slurpReloadCoalesce live
 		-- add an edge betwen the this reg and the last one stored into the slot
 		| RELOAD slot reg	<- instr
 		= case lookupUFM slotMap slot of
-			Just reg2	-> (slotMap, Just (reg, reg2))
+			Just reg2
+			 | reg /= reg2	-> (slotMap, Just (reg, reg2))
+			 | otherwise	-> (slotMap, Nothing)
+
 			Nothing		-> (slotMap, Nothing)
 
 		| otherwise