From 028c032b60567b8cd501e9d7248e4aa86088a19b Mon Sep 17 00:00:00 2001
From: "Ben.Lippmeier@anu.edu.au" <unknown>
Date: Thu, 17 Sep 2009 09:03:35 +0000
Subject: [PATCH] NCG: Add sanity checking to linear allocator If there are
 are unreachable basic blocks in the native code then the
 linear allocator might loop. Detect this case and panic
 instead.

---
 compiler/nativeGen/RegAlloc/Linear/Main.hs |   24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)

diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 229fd32..0014eec 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -190,7 +190,7 @@ linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs)
 
 linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) 
  = do
-        blockss' <- process first_id block_live blocks [] (return [])
+        blockss' <- process first_id block_live blocks [] (return []) False
 	linearRA_SCCs first_id block_live
 		(reverse (concat blockss') ++ blocksAcc)
 		sccs
@@ -207,13 +207,21 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs)
    more sanity checking to guard against this eventuality.
 -}
 		
-process _ _ [] []         accum 
+process _ _ [] []         accum _
 	= return $ reverse accum
 
-process first_id block_live [] next_round accum 
-	= process first_id block_live next_round [] accum
+process first_id block_live [] next_round accum madeProgress
+	| not madeProgress
+	= pprPanic "RegAlloc.Linear.Main.process: no progress made, bailing out" 
+		(  text "stalled blocks:"
+		$$ vcat (map ppr next_round))
+	
+	| otherwise
+	= process first_id block_live 
+		  next_round [] accum False
 
-process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum 
+process first_id block_live (b@(BasicBlock id _) : blocks) 
+	next_round accum madeProgress
  = do 	
 	block_assig <- getBlockAssigR
 
@@ -221,9 +229,11 @@ process first_id block_live (b@(BasicBlock id _) : blocks) next_round accum
              || id == first_id
          then do 
 		b'  <- processBlock block_live b
-                process first_id block_live blocks next_round (b' : accum)
+                process first_id block_live blocks 
+			next_round (b' : accum) True
 
-         else 	process first_id block_live blocks (b : next_round) accum
+         else 	process first_id block_live blocks 
+			(b : next_round) accum madeProgress
 
 
 -- | Do register allocation on this basic block
-- 
1.7.10.4