From 5a10dc1bf06a1fee238f60ffa8f8c2a574571abd Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 11 Apr 2005 13:51:45 +0000
Subject: [PATCH] [project @ 2005-04-11 13:51:45 by simonmar] Fix register
 allocation bug: at a branch destination we weren't setting
 the free register set correctly.  This may have resulted in
 poor code in some cases; worst case it causes a
 Prelude.head: empty list.

---
 ghc/compiler/nativeGen/RegisterAlloc.hs |   28 +++++++++++++++++++++-------
 1 file changed, 21 insertions(+), 7 deletions(-)

diff --git a/ghc/compiler/nativeGen/RegisterAlloc.hs b/ghc/compiler/nativeGen/RegisterAlloc.hs
index 4f71fe1..80f32e6 100644
--- a/ghc/compiler/nativeGen/RegisterAlloc.hs
+++ b/ghc/compiler/nativeGen/RegisterAlloc.hs
@@ -636,7 +636,8 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 			    | (temp, InReg reg) <- ufmToList assig,
 			      temp `notElem` keep', regClass (RealReg reg) == regClass r  ]
 	    -- in
-	    ASSERT2(not (null candidates1 && null candidates2), ppr assig) do
+	    ASSERT2(not (null candidates1 && null candidates2), 
+		    text (show freeregs) <+> ppr r <+> ppr assig) do
 
 	    case candidates1 of
 
@@ -656,7 +657,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 	     -- resides in a register.
 	     [] -> do
 	        let
-	          (temp_to_push_out, my_reg) = head candidates2
+	          (temp_to_push_out, my_reg) = myHead "regalloc" candidates2
 	          -- TODO: plenty of room for optimisation in choosing which temp
 	          -- to spill.  We just pick the first one that isn't used in 
 	          -- the current instruction for now.
@@ -678,6 +679,9 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 	do_load _ _ _ spills = 
 	   return spills
 
+myHead s [] = panic s
+myHead s (x:xs) = x
+
 -- -----------------------------------------------------------------------------
 -- Joining a jump instruction to its targets
 
@@ -703,18 +707,28 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
   let
 	-- adjust the assignment to remove any registers which are not
 	-- live on entry to the destination block.
-	adjusted_assig = 
-	  listToUFM [ (reg,loc) | reg <- live, 
-				  Just loc <- [lookupUFM assig reg] ]
+	adjusted_assig = filterUFM_Directly still_live assig
+	still_live uniq _ = uniq `elemUniqSet_Directly` live_set
+
+	-- and free up those registers which are now free.
+	to_free =
+	  [ r | (reg, loc) <- ufmToList assig, 
+		not (elemUniqSet_Directly reg live_set), 
+		r <- regsOfLoc loc ]
+
+	regsOfLoc (InReg r)    = [r]
+	regsOfLoc (InBoth r _) = [r]
+	regsOfLoc (InMem _)    = []
   -- in
   case lookupUFM block_assig dest of
 	-- Nothing <=> this is the first time we jumped to this
 	-- block.
 	Nothing -> do
 	  freeregs <- getFreeRegsR
+	  let freeregs' = foldr releaseReg freeregs to_free 
  	  stack <- getStackR
 	  setBlockAssigR (addToUFM block_assig dest 
-				(freeregs,stack,adjusted_assig))
+				(freeregs',stack,adjusted_assig))
 	  joinToTargets block_live new_blocks instr dests
 
 	Just (freeregs,stack,dest_assig)
@@ -725,7 +739,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
 	   -> -- need fixup code
 	     panic "joinToTargets: ToDo: need fixup code"
   where
-	live = uniqSetToList (lookItUp "joinToTargets" block_live dest)
+	live_set = lookItUp "joinToTargets" block_live dest
 
 -- -----------------------------------------------------------------------------
 -- The register allocator's monad.  
-- 
1.7.10.4