Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

3 files changed, 37 insertions, 32 deletions

diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 3f92ed975b..a15bca07e7 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -139,22 +139,27 @@ regAlloc
         :: (Outputable instr, Instruction instr)
         => DynFlags
         -> LiveCmmDecl statics instr
-        -> UniqSM (NatCmmDecl statics instr, Maybe RegAllocStats)
+        -> UniqSM ( NatCmmDecl statics instr
+                  , Maybe Int  -- number of extra stack slots required,
+                               -- beyond maxSpillSlots
+                  , Maybe RegAllocStats)
 
 regAlloc _ (CmmData sec d)
         = return
                 ( CmmData sec d
+                , Nothing
                 , Nothing )
 
 regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl [])
         = return ( CmmProc info lbl (ListGraph [])
+                 , Nothing
                  , Nothing )
 
 regAlloc dflags (CmmProc static lbl sccs)
         | LiveInfo info (Just first_id) (Just block_live) _     <- static
         = do
                 -- do register allocation on each component.
-                (final_blocks, stats)
+                (final_blocks, stats, stack_use)
                         <- linearRegAlloc dflags first_id block_live sccs
 
                 -- make sure the block that was first in the input list
@@ -162,7 +167,15 @@ regAlloc dflags (CmmProc static lbl sccs)
                 let ((first':_), rest')
                                 = partition ((== first_id) . blockId) final_blocks
 
+                let max_spill_slots = maxSpillSlots dflags
+                    extra_stack
+                      | stack_use > max_spill_slots
+                      = Just (stack_use - max_spill_slots)
+                      | otherwise
+                      = Nothing
+
                 return  ( CmmProc info lbl (ListGraph (first' : rest'))
+                        , extra_stack
                         , Just stats)
 
 -- bogus. to make non-exhaustive match warning go away.
@@ -184,7 +197,7 @@ linearRegAlloc
         -> BlockId                      -- ^ the first block
         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
-        -> UniqSM ([NatBasicBlock instr], RegAllocStats)
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
 
 linearRegAlloc dflags first_id block_live sccs
  = let platform = targetPlatform dflags
@@ -204,14 +217,14 @@ linearRegAlloc'
         -> BlockId                      -- ^ the first block
         -> BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
-        -> UniqSM ([NatBasicBlock instr], RegAllocStats)
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
 
 linearRegAlloc' dflags initFreeRegs first_id block_live sccs
  = do   us      <- getUs
-        let (_, _, stats, blocks) =
+        let (_, stack, stats, blocks) =
                 runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us
                     $ linearRA_SCCs first_id block_live [] sccs
-        return  (blocks, stats)
+        return  (blocks, stats, getStackUse stack)
 
 
 linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
index b1fc3c169e..69cf411751 100644
--- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
@@ -21,15 +21,13 @@ module RegAlloc.Linear.StackMap (
 	StackSlot,
 	StackMap(..),
 	emptyStackMap,
-	getStackSlotFor
+        getStackSlotFor,
+        getStackUse
 )
 
 where
 
-import RegAlloc.Linear.FreeRegs
-
 import DynFlags
-import Outputable
 import UniqFM
 import Unique
 
@@ -40,7 +38,7 @@ type StackSlot = Int
 data StackMap 
 	= StackMap 
 	{ -- | The slots that are still available to be allocated.
-	  stackMapFreeSlots	:: [StackSlot]
+          stackMapNextFreeSlot  :: !Int
 
 	  -- | Assignment of vregs to stack slots.
 	, stackMapAssignment	:: UniqFM StackSlot }
@@ -48,7 +46,7 @@ data StackMap
 
 -- | An empty stack map, with all slots available.
 emptyStackMap :: DynFlags -> StackMap
-emptyStackMap dflags = StackMap [0 .. maxSpillSlots dflags] emptyUFM
+emptyStackMap _ = StackMap 0 emptyUFM
 
 
 -- | If this vreg unique already has a stack assignment then return the slot number,
@@ -56,24 +54,13 @@ emptyStackMap dflags = StackMap [0 .. maxSpillSlots dflags] emptyUFM
 --
 getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)
 
-getStackSlotFor (StackMap [] _) _
-
-        -- This happens all the time when trying to compile darcs' SHA1.hs, see Track #1993
-	--	SHA1.lhs has also been added to the Crypto library on Hackage,
-	--	so we see this all the time.  
-	--
-	-- It would be better to automatically invoke the graph allocator, or do something
-	--	else besides panicing, but that's a job for a different day.  -- BL 2009/02
-	--
-	= panic $   "RegAllocLinear.getStackSlotFor: out of stack slots\n"
-		++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
-		++  "   is a known limitation in the linear allocator.\n"
-		++  "\n"
-		++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
-		++  "   You can still file a bug report if you like.\n"
-		
-getStackSlotFor fs@(StackMap (freeSlot:stack') reserved) reg =
-    case lookupUFM reserved reg of
-    	Just slot	-> (fs, slot)
-    	Nothing		-> (StackMap stack' (addToUFM reserved reg freeSlot), freeSlot)
+getStackSlotFor fs@(StackMap _ reserved) reg
+  | Just slot <- lookupUFM reserved reg  =  (fs, slot)
+
+getStackSlotFor (StackMap freeSlot reserved) reg =
+    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)
+
+-- | Return the number of stack slots that were allocated
+getStackUse :: StackMap -> Int
+getStackUse (StackMap freeSlot _) = freeSlot
 
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 85b8f969eb..608f0a423b 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -136,6 +136,11 @@ instance Instruction instr => Instruction (InstrSR instr) where
 
         mkJumpInstr target      = map Instr (mkJumpInstr target)
 
+        mkStackAllocInstr platform amount =
+             Instr (mkStackAllocInstr platform amount)
+
+        mkStackDeallocInstr platform amount =
+             Instr (mkStackDeallocInstr platform amount)
 
 
 -- | An instruction with liveness information.