summaryrefslogtreecommitdiff
path: root/compiler/nativeGen/RegAlloc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/nativeGen/RegAlloc')
-rw-r--r--compiler/nativeGen/RegAlloc/Graph/Stats.hs400
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/Main.hs25
-rw-r--r--compiler/nativeGen/RegAlloc/Linear/StackMap.hs39
-rw-r--r--compiler/nativeGen/RegAlloc/Liveness.hs7
4 files changed, 238 insertions, 233 deletions
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
index 32970336ad..f85cdb7eff 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -1,23 +1,16 @@
-{-# OPTIONS -fno-warn-missing-signatures #-}
--- | Carries interesting info for debugging / profiling of the
--- graph coloring register allocator.
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
+-- | Carries interesting info for debugging / profiling of the
+-- graph coloring register allocator.
module RegAlloc.Graph.Stats (
- RegAllocStats (..),
+ RegAllocStats (..),
- pprStats,
- pprStatsSpills,
- pprStatsLifetimes,
- pprStatsConflict,
- pprStatsLifeConflict,
+ pprStats,
+ pprStatsSpills,
+ pprStatsLifetimes,
+ pprStatsConflict,
+ pprStatsLifeConflict,
- countSRMs, addSRM
+ countSRMs, addSRM
)
where
@@ -45,251 +38,260 @@ import Data.List
data RegAllocStats statics instr
- -- initial graph
- = RegAllocStatsStart
- { raLiveCmm :: [LiveCmmDecl statics instr] -- ^ initial code, with liveness
- , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph
- , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill
-
- -- a spill stage
- | RegAllocStatsSpill
- { raCode :: [LiveCmmDecl statics instr] -- ^ the code we tried to allocate registers for
- , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph
- , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced
- , raSpillStats :: SpillStats -- ^ spiller stats
- , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for
- , raSpilled :: [LiveCmmDecl statics instr] } -- ^ code with spill instructions added
-
- -- a successful coloring
- | RegAllocStatsColored
- { raCode :: [LiveCmmDecl statics instr] -- ^ the code we tried to allocate registers for
- , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph
- , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph
- , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced
- , raCodeCoalesced :: [LiveCmmDecl statics instr] -- ^ code with coalescings applied
- , raPatched :: [LiveCmmDecl statics instr] -- ^ code with vregs replaced by hregs
- , raSpillClean :: [LiveCmmDecl statics instr] -- ^ code with unneeded spill\/reloads cleaned out
- , raFinal :: [NatCmmDecl statics instr] -- ^ final code
- , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code
+ -- initial graph
+ = RegAllocStatsStart
+ { raLiveCmm :: [LiveCmmDecl statics instr] -- ^ initial code, with liveness
+ , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph
+ , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill
+
+ -- a spill stage
+ | RegAllocStatsSpill
+ { raCode :: [LiveCmmDecl statics instr] -- ^ the code we tried to allocate registers for
+ , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph
+ , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced
+ , raSpillStats :: SpillStats -- ^ spiller stats
+ , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for
+ , raSpilled :: [LiveCmmDecl statics instr] } -- ^ code with spill instructions added
+
+ -- a successful coloring
+ | RegAllocStatsColored
+ { raCode :: [LiveCmmDecl statics instr] -- ^ the code we tried to allocate registers for
+ , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph
+ , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph
+ , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced
+ , raCodeCoalesced :: [LiveCmmDecl statics instr] -- ^ code with coalescings applied
+ , raPatched :: [LiveCmmDecl statics instr] -- ^ code with vregs replaced by hregs
+ , raSpillClean :: [LiveCmmDecl statics instr] -- ^ code with unneeded spill\/reloads cleaned out
+ , raFinal :: [NatCmmDecl statics instr] -- ^ final code
+ , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code
instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where
ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform ->
- text "# Start"
- $$ text "# Native code with liveness information."
- $$ ppr (raLiveCmm s)
- $$ text ""
- $$ text "# Initial register conflict graph."
- $$ Color.dotGraph
- (targetRegDotColor platform)
- (trivColorable platform
- (targetVirtualRegSqueeze platform)
- (targetRealRegSqueeze platform))
- (raGraph s)
+ text "# Start"
+ $$ text "# Native code with liveness information."
+ $$ ppr (raLiveCmm s)
+ $$ text ""
+ $$ text "# Initial register conflict graph."
+ $$ Color.dotGraph
+ (targetRegDotColor platform)
+ (trivColorable platform
+ (targetVirtualRegSqueeze platform)
+ (targetRealRegSqueeze platform))
+ (raGraph s)
ppr (s@RegAllocStatsSpill{}) =
- text "# Spill"
+ text "# Spill"
- $$ text "# Code with liveness information."
- $$ ppr (raCode s)
- $$ text ""
+ $$ text "# Code with liveness information."
+ $$ ppr (raCode s)
+ $$ text ""
- $$ (if (not $ isNullUFM $ raCoalesced s)
- then text "# Registers coalesced."
- $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
- $$ text ""
- else empty)
+ $$ (if (not $ isNullUFM $ raCoalesced s)
+ then text "# Registers coalesced."
+ $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
+ $$ text ""
+ else empty)
- $$ text "# Spills inserted."
- $$ ppr (raSpillStats s)
- $$ text ""
+ $$ text "# Spills inserted."
+ $$ ppr (raSpillStats s)
+ $$ text ""
- $$ text "# Code with spills inserted."
- $$ ppr (raSpilled s)
+ $$ text "# Code with spills inserted."
+ $$ ppr (raSpilled s)
ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = sdocWithPlatform $ \platform ->
- text "# Colored"
-
- $$ text "# Code with liveness information."
- $$ ppr (raCode s)
- $$ text ""
-
- $$ text "# Register conflict graph (colored)."
- $$ Color.dotGraph
- (targetRegDotColor platform)
- (trivColorable platform
- (targetVirtualRegSqueeze platform)
- (targetRealRegSqueeze platform))
- (raGraphColored s)
- $$ text ""
-
- $$ (if (not $ isNullUFM $ raCoalesced s)
- then text "# Registers coalesced."
- $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
- $$ text ""
- else empty)
-
- $$ text "# Native code after coalescings applied."
- $$ ppr (raCodeCoalesced s)
- $$ text ""
-
- $$ text "# Native code after register allocation."
- $$ ppr (raPatched s)
- $$ text ""
-
- $$ text "# Clean out unneeded spill/reloads."
- $$ ppr (raSpillClean s)
- $$ text ""
-
- $$ text "# Final code, after rewriting spill/rewrite pseudo instrs."
- $$ ppr (raFinal s)
- $$ text ""
- $$ text "# Score:"
- $$ (text "# spills inserted: " <> int spills)
- $$ (text "# reloads inserted: " <> int reloads)
- $$ (text "# reg-reg moves remaining: " <> int moves)
- $$ text ""
+ text "# Colored"
+
+ $$ text "# Code with liveness information."
+ $$ ppr (raCode s)
+ $$ text ""
+
+ $$ text "# Register conflict graph (colored)."
+ $$ Color.dotGraph
+ (targetRegDotColor platform)
+ (trivColorable platform
+ (targetVirtualRegSqueeze platform)
+ (targetRealRegSqueeze platform))
+ (raGraphColored s)
+ $$ text ""
+
+ $$ (if (not $ isNullUFM $ raCoalesced s)
+ then text "# Registers coalesced."
+ $$ (vcat $ map ppr $ ufmToList $ raCoalesced s)
+ $$ text ""
+ else empty)
+
+ $$ text "# Native code after coalescings applied."
+ $$ ppr (raCodeCoalesced s)
+ $$ text ""
+
+ $$ text "# Native code after register allocation."
+ $$ ppr (raPatched s)
+ $$ text ""
+
+ $$ text "# Clean out unneeded spill/reloads."
+ $$ ppr (raSpillClean s)
+ $$ text ""
+
+ $$ text "# Final code, after rewriting spill/rewrite pseudo instrs."
+ $$ ppr (raFinal s)
+ $$ text ""
+ $$ text "# Score:"
+ $$ (text "# spills inserted: " <> int spills)
+ $$ (text "# reloads inserted: " <> int reloads)
+ $$ (text "# reg-reg moves remaining: " <> int moves)
+ $$ text ""
-- | Do all the different analysis on this list of RegAllocStats
-pprStats
- :: [RegAllocStats statics instr]
- -> Color.Graph VirtualReg RegClass RealReg
- -> SDoc
-
+pprStats
+ :: [RegAllocStats statics instr]
+ -> Color.Graph VirtualReg RegClass RealReg
+ -> SDoc
+
pprStats stats graph
- = let outSpills = pprStatsSpills stats
- outLife = pprStatsLifetimes stats
- outConflict = pprStatsConflict stats
- outScatter = pprStatsLifeConflict stats graph
+ = let outSpills = pprStatsSpills stats
+ outLife = pprStatsLifetimes stats
+ outConflict = pprStatsConflict stats
+ outScatter = pprStatsLifeConflict stats graph
- in vcat [outSpills, outLife, outConflict, outScatter]
+ in vcat [outSpills, outLife, outConflict, outScatter]
-- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
pprStatsSpills
- :: [RegAllocStats statics instr] -> SDoc
+ :: [RegAllocStats statics instr] -> SDoc
pprStatsSpills stats
= let
- finals = [ s | s@RegAllocStatsColored{} <- stats]
+ finals = [ s | s@RegAllocStatsColored{} <- stats]
- -- sum up how many stores\/loads\/reg-reg-moves were left in the code
- total = foldl' addSRM (0, 0, 0)
- $ map raSRMs finals
+ -- sum up how many stores\/loads\/reg-reg-moves were left in the code
+ total = foldl' addSRM (0, 0, 0)
+ $ map raSRMs finals
- in ( text "-- spills-added-total"
- $$ text "-- (stores, loads, reg_reg_moves_remaining)"
- $$ ppr total
- $$ text "")
+ in ( text "-- spills-added-total"
+ $$ text "-- (stores, loads, reg_reg_moves_remaining)"
+ $$ ppr total
+ $$ text "")
-- | Dump a table of how long vregs tend to live for in the initial code.
pprStatsLifetimes
- :: [RegAllocStats statics instr] -> SDoc
+ :: [RegAllocStats statics instr] -> SDoc
pprStatsLifetimes stats
- = let info = foldl' plusSpillCostInfo zeroSpillCostInfo
- [ raSpillCosts s
- | s@RegAllocStatsStart{} <- stats ]
+ = let info = foldl' plusSpillCostInfo zeroSpillCostInfo
+ [ raSpillCosts s
+ | s@RegAllocStatsStart{} <- stats ]
- lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info
+ lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info
- in ( text "-- vreg-population-lifetimes"
- $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)"
- $$ (vcat $ map ppr $ eltsUFM lifeBins)
- $$ text "\n")
+ in ( text "-- vreg-population-lifetimes"
+ $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)"
+ $$ (vcat $ map ppr $ eltsUFM lifeBins)
+ $$ text "\n")
binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
binLifetimeCount fm
- = let lifes = map (\l -> (l, (l, 1)))
- $ map snd
- $ eltsUFM fm
+ = let lifes = map (\l -> (l, (l, 1)))
+ $ map snd
+ $ eltsUFM fm
- in addListToUFM_C
- (\(l1, c1) (_, c2) -> (l1, c1 + c2))
- emptyUFM
- lifes
+ in addListToUFM_C
+ (\(l1, c1) (_, c2) -> (l1, c1 + c2))
+ emptyUFM
+ lifes
-- | Dump a table of how many conflicts vregs tend to have in the initial code.
pprStatsConflict
- :: [RegAllocStats statics instr] -> SDoc
+ :: [RegAllocStats statics instr] -> SDoc
pprStatsConflict stats
- = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
- emptyUFM
- $ map Color.slurpNodeConflictCount
- [ raGraph s | s@RegAllocStatsStart{} <- stats ]
+ = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
+ emptyUFM
+ $ map Color.slurpNodeConflictCount
+ [ raGraph s | s@RegAllocStatsStart{} <- stats ]
- in ( text "-- vreg-conflicts"
- $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
- $$ (vcat $ map ppr $ eltsUFM confMap)
- $$ text "\n")
+ in ( text "-- vreg-conflicts"
+ $$ text "-- (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
+ $$ (vcat $ map ppr $ eltsUFM confMap)
+ $$ text "\n")
-- | For every vreg, dump it's how many conflicts it has and its lifetime
--- good for making a scatter plot.
+-- good for making a scatter plot.
pprStatsLifeConflict
- :: [RegAllocStats statics instr]
- -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
- -> SDoc
+ :: [RegAllocStats statics instr]
+ -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
+ -> SDoc
pprStatsLifeConflict stats graph
- = let lifeMap = lifeMapFromSpillCostInfo
- $ foldl' plusSpillCostInfo zeroSpillCostInfo
- $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
-
- scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of
- Just (_, l) -> l
- Nothing -> 0
- Just node = Color.lookupNode graph r
- in parens $ hcat $ punctuate (text ", ")
- [ doubleQuotes $ ppr $ Color.nodeId node
- , ppr $ sizeUniqSet (Color.nodeConflicts node)
- , ppr $ lifetime ])
- $ map Color.nodeId
- $ eltsUFM
- $ Color.graphMap graph
-
- in ( text "-- vreg-conflict-lifetime"
- $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)"
- $$ (vcat scatter)
- $$ text "\n")
+ = let lifeMap = lifeMapFromSpillCostInfo
+ $ foldl' plusSpillCostInfo zeroSpillCostInfo
+ $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
+
+ scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of
+ Just (_, l) -> l
+ Nothing -> 0
+ Just node = Color.lookupNode graph r
+ in parens $ hcat $ punctuate (text ", ")
+ [ doubleQuotes $ ppr $ Color.nodeId node
+ , ppr $ sizeUniqSet (Color.nodeConflicts node)
+ , ppr $ lifetime ])
+ $ map Color.nodeId
+ $ eltsUFM
+ $ Color.graphMap graph
+
+ in ( text "-- vreg-conflict-lifetime"
+ $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)"
+ $$ (vcat scatter)
+ $$ text "\n")
-- | Count spill/reload/reg-reg moves.
--- Lets us see how well the register allocator has done.
-countSRMs
- :: Instruction instr
- => LiveCmmDecl statics instr -> (Int, Int, Int)
+-- Lets us see how well the register allocator has done.
+countSRMs
+ :: Instruction instr
+ => LiveCmmDecl statics instr -> (Int, Int, Int)
countSRMs cmm
- = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
+ = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
+countSRM_block :: Instruction instr
+ => GenBasicBlock (LiveInstr instr)
+ -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
countSRM_block (BasicBlock i instrs)
- = do instrs' <- mapM countSRM_instr instrs
- return $ BasicBlock i instrs'
+ = do instrs' <- mapM countSRM_instr instrs
+ return $ BasicBlock i instrs'
+countSRM_instr :: Instruction instr
+ => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
countSRM_instr li
- | LiveInstr SPILL{} _ <- li
- = do modify $ \(s, r, m) -> (s + 1, r, m)
- return li
-
- | LiveInstr RELOAD{} _ <- li
- = do modify $ \(s, r, m) -> (s, r + 1, m)
- return li
-
- | LiveInstr instr _ <- li
- , Just _ <- takeRegRegMoveInstr instr
- = do modify $ \(s, r, m) -> (s, r, m + 1)
- return li
-
- | otherwise
- = return li
+ | LiveInstr SPILL{} _ <- li
+ = do modify $ \(s, r, m) -> (s + 1, r, m)
+ return li
+
+ | LiveInstr RELOAD{} _ <- li
+ = do modify $ \(s, r, m) -> (s, r + 1, m)
+ return li
+
+ | LiveInstr instr _ <- li
+ , Just _ <- takeRegRegMoveInstr instr
+ = do modify $ \(s, r, m) -> (s, r, m + 1)
+ return li
+
+ | otherwise
+ = return li
-- sigh..
+addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
addSRM (s1, r1, m1) (s2, r2, m2)
- = (s1+s2, r1+r2, m1+m2)
+ = let !s = s1 + s2
+ !r = r1 + r2
+ !m = m1 + m2
+ in (s, r, m)
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 ac58944f1c..608f0a423b 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -5,8 +5,6 @@
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-
module RegAlloc.Liveness (
RegSet,
RegMap, emptyRegMap,
@@ -138,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.
View Lorry Controller Status