X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=e6491b77ee9a15cdbc437d30e2067c47a5695530;hp=c3a731910256bcc5f6959bd3cb0660d00d8dcc1a;hb=e3971de1fe67e414060047c09c4d5c64c7083981;hpb=272f0ba89eca1d9fc700cf4c27b9f8c3e23d6fe8

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index c3a7319..e6491b7 100644
--- a/compiler/nativeGen/RegAllocLinear.hs
+++ b/compiler/nativeGen/RegAllocLinear.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS -fno-warn-missing-signatures #-}
 -----------------------------------------------------------------------------
 --
 -- The register allocator
@@ -5,7 +6,6 @@
 -- (c) The University of Glasgow 2004
 --
 -----------------------------------------------------------------------------
-{-# OPTIONS -fno-warn-missing-signatures #-}
 
 {-
 The algorithm is roughly:
@@ -92,7 +92,7 @@ import MachRegs
 import MachInstrs
 import RegAllocInfo
 import RegLiveness
-import Cmm
+import Cmm hiding (RegSet)
 
 import Digraph
 import Unique		( Uniquable(getUnique), Unique )
@@ -102,11 +102,9 @@ import UniqSupply
 import Outputable
 import State
 
-#ifndef DEBUG
-import Data.Maybe	( fromJust )
-#endif
-import Data.List	( nub, partition, foldl')
-import Control.Monad	( when )
+import Data.Maybe
+import Data.List
+import Control.Monad
 import Data.Word
 import Data.Bits
 
@@ -157,8 +155,9 @@ getFreeRegs :: RegClass -> FreeRegs -> [RegNo]	-- lazilly
 getFreeRegs cls (FreeRegs g f)
     | RcDouble <- cls = go f (0x80000000) 63
     | RcInteger <- cls = go g (0x80000000) 31
+    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad cls" (ppr cls)
     where
-        go x 0 i = []
+        go _ 0 _ = []
         go x m i | x .&. m /= 0 = i : (go x (m `shiftR` 1) $! i-1)
                  | otherwise    = go x (m `shiftR` 1) $! i-1
 
@@ -223,7 +222,9 @@ emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM
 
 getStackSlotFor :: StackMap -> Unique -> (StackMap,Int)
 getStackSlotFor (StackMap [] _) _
-	= panic "RegAllocLinear.getStackSlotFor: out of stack slots"
+	= panic "RegAllocLinear.getStackSlotFor: out of stack slots, try -fregs-graph"
+        -- This happens with darcs' SHA1.hs, see #1993
+
 getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
     case lookupUFM reserved reg of
     	Just slot -> (fs,slot)
@@ -242,12 +243,12 @@ regAlloc (CmmData sec d)
 		( CmmData sec d
 		, Nothing )
 	
-regAlloc (CmmProc (LiveInfo info _ _) lbl params [])
+regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
 	= return
-		( CmmProc info lbl params []
+		( CmmProc info lbl params (ListGraph [])
 		, Nothing )
 	
-regAlloc (CmmProc static lbl params comps)
+regAlloc (CmmProc static lbl params (ListGraph comps))
 	| LiveInfo info (Just first_id) block_live	<- static
 	= do	
  		-- do register allocation on each component.
@@ -263,7 +264,7 @@ regAlloc (CmmProc static lbl params comps)
 		let ((first':_), rest')
 				= partition ((== first_id) . blockId) final_blocks
 
-		return	( CmmProc info lbl params (first' : rest')
+		return	( CmmProc info lbl params (ListGraph (first' : rest'))
 			, Just stats)
 	
 -- bogus. to make non-exhaustive match warning go away.
@@ -292,10 +293,8 @@ save it in a spill location, but mark it as InBoth because the current
 instruction might still want to read it.
 -}
 
-#ifdef DEBUG
 instance Outputable Loc where
   ppr l = text (show l)
-#endif
 
 
 -- | Do register allocation on some basic blocks.
@@ -1111,7 +1110,7 @@ pprStats code statss
 
 #ifdef DEBUG
 my_fromJust s p Nothing  = pprPanic ("fromJust: " ++ s) p
-my_fromJust s p (Just x) = x
+my_fromJust _ _ (Just x) = x
 #else
 my_fromJust _ _ = fromJust
 #endif