X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegAllocLinear.hs;h=918d7c64c5d578e3b0cc60bc02311741d2887b3d;hb=987530c1d23a59b986a54ba2bc9e198061fdcae9;hp=b99abe3841e2f80dee3402e323381fa32f1e6176;hpb=a8312580d6f089d153d8af668484d4c2eb75e8a8;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index b99abe3..918d7c6 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:
@@ -88,11 +88,12 @@ module RegAllocLinear (
 
 #include "HsVersions.h"
 
+import BlockId
 import MachRegs
 import MachInstrs
 import RegAllocInfo
 import RegLiveness
-import Cmm
+import Cmm hiding (RegSet)
 
 import Digraph
 import Unique		( Uniquable(getUnique), Unique )
@@ -101,12 +102,11 @@ import UniqFM
 import UniqSupply
 import Outputable
 import State
+import FastString
 
-#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 +157,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 +224,8 @@ 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
@@ -293,10 +295,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.
@@ -576,7 +576,7 @@ saveClobberedTemps clobbered dying =  do
 	recordSpill (SpillClobber temp)
 
 	let new_assign	= addToUFM assig temp (InBoth reg slot)
-	clobber new_assign (spill : COMMENT FSLIT("spill clobber") : instrs) rest
+	clobber new_assign (spill : COMMENT (fsLit "spill clobber") : instrs) rest
 
 clobberRegs :: [RegNo] -> RegM ()
 clobberRegs [] = return () -- common case
@@ -693,7 +693,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) = do
 
     	        (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out
 		let spill_store	 = (if reading then id else reverse)
-					[ COMMENT FSLIT("spill alloc") 
+					[ COMMENT (fsLit "spill alloc") 
 					, spill_insn ]
 
 		-- record that this temp was spilled
@@ -725,7 +725,7 @@ loadTemp True vreg (Just (InMem slot)) hreg spills
  = do
  	insn <- loadR (RealReg hreg) slot
 	recordSpill (SpillLoad $ getUnique vreg)
-	return	$  COMMENT FSLIT("spill load") : insn : spills
+	return	$  COMMENT (fsLit "spill load") : insn : spills
 
 loadTemp _ _ _ _ spills =
    return spills
@@ -797,7 +797,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
 	       delta <- getDeltaR
 	       
                let graph = makeRegMovementGraph adjusted_assig dest_assig
-	       let sccs  = stronglyConnCompR graph
+	       let sccs  = stronglyConnCompFromEdgedVerticesR graph
 	       fixUpInstrs <- mapM (handleComponent delta instr) sccs
 
 	       block_id <- getUniqueR
@@ -809,7 +809,7 @@ joinToTargets block_live new_blocks instr (dest:dests) = do
 	       joinToTargets block_live (block : new_blocks) instr' dests
 
 
--- | Construct a graph of register/spill movements.
+-- | Construct a graph of register\/spill movements.
 --
 -- 	We cut some corners by
 -- 	a) not handling cyclic components
@@ -827,7 +827,7 @@ makeRegMovementGraph adjusted_assig dest_assig
 	 = expandNode vreg src
 	 $ lookupWithDefaultUFM_Directly
            	dest_assig
-                (panic "RegisterAlloc.joinToTargets")
+                (panic "RegAllocLinear.makeRegMovementGraph")
 		vreg
 
    in	[ node 	| (vreg, src) <- ufmToList adjusted_assig
@@ -901,7 +901,7 @@ handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
  = do
 	spill_id <- getUniqueR
 	(_, slot) 		<- spillR (RealReg sreg) spill_id
-	remainingFixUps 	<- mapM (handleComponent delta instr) (stronglyConnCompR rest)
+	remainingFixUps 	<- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest)
 	restoreAndFixInstr 	<- getRestoreMoves dsts slot
 	return ([instr] ++ concat remainingFixUps ++ restoreAndFixInstr)
 
@@ -910,7 +910,7 @@ handleComponent delta instr (CyclicSCC ((vreg, (InReg sreg),dsts):rest))
 	 = do
 		restoreToReg 	<- loadR (RealReg reg) slot
 		moveInstr	<- makeMove delta vreg r mem
-		return $ [COMMENT FSLIT("spill join move"), restoreToReg, moveInstr]
+		return $ [COMMENT (fsLit "spill join move"), restoreToReg, moveInstr]
 
 	getRestoreMoves [InReg reg] slot
 		= loadR (RealReg reg) slot >>= return . (:[])
@@ -1110,12 +1110,9 @@ pprStats code statss
 -- -----------------------------------------------------------------------------
 -- Utils
 
-#ifdef DEBUG
-my_fromJust s p Nothing  = pprPanic ("fromJust: " ++ s) p
-my_fromJust s p (Just x) = x
-#else
-my_fromJust _ _ = fromJust
-#endif
+my_fromJust :: String -> SDoc -> Maybe a -> a
+my_fromJust _ _ (Just x) = x
+my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p
 
 lookItUp :: Uniquable b => String -> UniqFM a -> b -> a
 lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x)