Commit b92c76ec authored by ian@well-typed.com's avatar ian@well-typed.com

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

parents 85a8f79f a9109703
......@@ -5,6 +5,7 @@ module CmmLayoutStack (
import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX
import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX
import StgCmmLayout ( entryCode ) -- XXX
import Cmm
import BlockId
......@@ -939,7 +940,8 @@ lowerSafeForeignCall dflags block
-- received an exception during the call, then the stack might be
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags)
jump = CmmCall { cml_target = entryCode dflags $
CmmLoad (CmmReg spReg) (bWord dflags)
, cml_cont = Just succ
, cml_args_regs = regs
, cml_args = widthInBytes (wordWidth dflags)
......
......@@ -114,7 +114,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
procPointAnalysis proc_points g
dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g)
splitAtProcPoints dflags l call_pps proc_points pp_map
(CmmProc h l g)
dumps Opt_D_dump_cmmz_split "Post splitting" gs
------------- Populate info tables with stack info -----------------
......
......@@ -11,6 +11,7 @@ where
import Prelude hiding (last, unzip, succ, zip)
import DynFlags
import BlockId
import CLabel
import Cmm
......@@ -26,8 +27,6 @@ import UniqSupply
import Hoopl
import qualified Data.Map as Map
-- Compute a minimal set of proc points for a control-flow graph.
-- Determine a protocol for each proc point (which live variables will
......@@ -207,9 +206,9 @@ extendPPSet platform g blocks procPoints =
-- Input invariant: A block should only be reachable from a single ProcPoint.
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmDecl -> UniqSM [CmmDecl]
splitAtProcPoints entry_label callPPs procPoints procMap
splitAtProcPoints dflags entry_label callPPs procPoints procMap
(CmmProc (TopInfo {info_tbls = info_tbls})
top_l g@(CmmGraph {g_entry=entry})) =
do -- Build a map from procpoints to the blocks they reach
......@@ -234,12 +233,15 @@ splitAtProcPoints entry_label callPPs procPoints procMap
-- * Labels for the info tables of their new procedures (only if
-- the proc point is a callPP)
-- Due to common blockification, we may overestimate the set of procpoints.
let add_label map pp = Map.insert pp lbls map
let add_label map pp = mapInsert pp lbls map
where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
| otherwise = (blockLbl pp, guard (setMember pp callPPs) >>
Just (infoTblLbl pp))
procLabels = foldl add_label Map.empty
procLabels :: LabelMap (CLabel, Maybe CLabel)
procLabels = foldl add_label mapEmpty
(filter (flip mapMember (toBlockMap g)) (setElems procPoints))
-- In each new graph, add blocks jumping off to the new procedures,
-- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block (env, bs) (pp, l) =
......@@ -259,8 +261,17 @@ splitAtProcPoints entry_label callPPs procPoints procMap
CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
_ -> rst
add_if_pp id rst = case Map.lookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst
-- when jumping to a PP that has an info table, if
-- tablesNextToCode is off we must jump to the entry
-- label instead.
jump_label (Just info_lbl) _
| tablesNextToCode dflags = info_lbl
| otherwise = toEntryLbl info_lbl
jump_label Nothing block_lbl = block_lbl
add_if_pp id rst = case mapLookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
Nothing -> rst
(jumpEnv, jumpBlocks) <-
foldM add_jump_block (mapEmpty, []) needed_jumps
......@@ -274,8 +285,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap
let g' = ofBlockMap ppId blockEnv'''
-- pprTrace "g' pre jumps" (ppr g') $ do
return (mapInsert ppId g' newGraphEnv)
graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of
let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
(lbl, Just info_lbl)
| bid == entry
-> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info})
......@@ -295,7 +308,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
replacePPIds g = {-# SCC "replacePPIds" #-}
mapGraphNodes (id, mapExp repl, mapExp repl) g
where repl e@(CmmLit (CmmBlock bid)) =
case Map.lookup bid procLabels of
case mapLookup bid procLabels of
Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl)
_ -> e
repl e = e
......@@ -312,7 +325,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap
return -- pprTrace "procLabels" (ppr procLabels)
-- pprTrace "splitting graphs" (ppr procs)
procs
splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
......
......@@ -11,7 +11,7 @@ module MkGraph
, mkJumpReturnsTo
, mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC
, mkCbranch, mkSwitch
, mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
, mkReturn, mkComment, mkCallEntry, mkBranch
, copyInOflow, copyOutOflow
, noExtraStack
, toCall, Transfer(..)
......@@ -69,34 +69,38 @@ flattenCmmAGraph id stmts =
CmmGraph { g_entry = id,
g_graph = GMany NothingO body NothingO }
where
blocks = flatten1 (fromOL stmts) (blockJoinHead (CmmEntry id) emptyBlock) []
body = foldr addBlock emptyBody blocks
body = foldr addBlock emptyBody $ flatten id stmts []
--
-- flatten: turn a list of CgStmt into a list of Blocks. We know
-- that any code before the first label is unreachable, so just drop
-- it.
-- flatten: given an entry label and a CmmAGraph, make a list of blocks.
--
-- NB. avoid the quadratic-append trap by passing in the tail of the
-- list. This is important for Very Long Functions (e.g. in T783).
--
flatten :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten [] blocks = blocks
flatten :: Label -> CmmAGraph -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten id g blocks
= flatten1 (fromOL g) (blockJoinHead (CmmEntry id) emptyBlock) blocks
flatten (CgLabel id : stmts) blocks
--
-- flatten0: we are outside a block at this point: any code before
-- the first label is unreachable, so just drop it.
--
flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
flatten0 [] blocks = blocks
flatten0 (CgLabel id : stmts) blocks
= flatten1 stmts block blocks
where !block = blockJoinHead (CmmEntry id) emptyBlock
flatten (CgFork fork_id stmts : rest) blocks
= flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $
flatten rest blocks
flatten0 (CgFork fork_id stmts : rest) blocks
= flatten fork_id stmts $ flatten0 rest blocks
flatten (CgLast _ : stmts) blocks = flatten stmts blocks
flatten (CgStmt _ : stmts) blocks = flatten stmts blocks
flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
--
-- flatten1: we have a partial block, collect statements until the
-- next last node to make a block, then call flatten to get the rest
-- next last node to make a block, then call flatten0 to get the rest
-- of the blocks
--
flatten1 :: [CgStmt] -> Block CmmNode C O
......@@ -112,7 +116,7 @@ flattenCmmAGraph id stmts =
= blockJoinTail block (CmmBranch (entryLabel block)) : blocks
flatten1 (CgLast stmt : stmts) block blocks
= block' : flatten stmts blocks
= block' : flatten0 stmts blocks
where !block' = blockJoinTail block stmt
flatten1 (CgStmt stmt : stmts) block blocks
......@@ -120,8 +124,7 @@ flattenCmmAGraph id stmts =
where !block' = blockSnoc block stmt
flatten1 (CgFork fork_id stmts : rest) block blocks
= flatten1 (fromOL stmts) (blockJoinHead (CmmEntry fork_id) emptyBlock) $
flatten1 rest block blocks
= flatten fork_id stmts $ flatten1 rest block blocks
-- a label here means that we should start a new block, and the
-- current block should fall through to the new block.
......@@ -228,11 +231,6 @@ mkReturn dflags e actuals updfr_off =
lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
......
......@@ -85,7 +85,9 @@ emitReturn results
; case sequel of
Return _ ->
do { adjustHpBackwards
; emit (mkReturnSimple dflags results updfr_off) }
; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
; emit (mkReturn dflags (entryCode dflags e) results updfr_off)
}
AssignTo regs adjust ->
do { when adjust adjustHpBackwards
; emitMultiAssign regs results }
......
......@@ -133,16 +133,17 @@ The machine-dependent bits break down as follows:
data NcgImpl statics instr jumpDest = NcgImpl {
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
generateJumpTableForInstr :: DynFlags -> instr -> Maybe (NatCmmDecl statics instr),
generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
canShortcut :: instr -> Maybe jumpDest,
shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc,
maxSpillSlots :: DynFlags -> Int,
allocatableRegs :: Platform -> [RealReg],
maxSpillSlots :: Int,
allocatableRegs :: [RealReg],
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr,
ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
}
......@@ -154,15 +155,16 @@ nativeCodeGen dflags h us cmms
nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
x86NcgImpl = NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
,canShortcut = X86.Instr.canShortcut
,shortcutStatics = X86.Instr.shortcutStatics
,shortcutJump = X86.Instr.shortcutJump
,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl
,maxSpillSlots = X86.Instr.maxSpillSlots
,allocatableRegs = X86.Regs.allocatableRegs
,maxSpillSlots = X86.Instr.maxSpillSlots dflags
,allocatableRegs = X86.Regs.allocatableRegs platform
,ncg_x86fp_kludge = id
,ncgAllocMoreStack = X86.Instr.allocMoreStack platform
,ncgExpandTop = id
,ncgMakeFarBranches = id
}
......@@ -172,30 +174,32 @@ nativeCodeGen dflags h us cmms
ArchPPC ->
nCG' $ NcgImpl {
cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
,canShortcut = PPC.RegInfo.canShortcut
,shortcutStatics = PPC.RegInfo.shortcutStatics
,shortcutJump = PPC.RegInfo.shortcutJump
,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl
,maxSpillSlots = PPC.Instr.maxSpillSlots
,allocatableRegs = PPC.Regs.allocatableRegs
,maxSpillSlots = PPC.Instr.maxSpillSlots dflags
,allocatableRegs = PPC.Regs.allocatableRegs platform
,ncg_x86fp_kludge = id
,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = id
,ncgMakeFarBranches = makeFarBranches
}
ArchSPARC ->
nCG' $ NcgImpl {
cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
,canShortcut = SPARC.ShortcutJump.canShortcut
,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
,shortcutJump = SPARC.ShortcutJump.shortcutJump
,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl
,maxSpillSlots = SPARC.Instr.maxSpillSlots
,allocatableRegs = \_ -> SPARC.Regs.allocatableRegs
,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags
,allocatableRegs = SPARC.Regs.allocatableRegs
,ncg_x86fp_kludge = id
,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
,ncgMakeFarBranches = id
}
......@@ -206,6 +210,23 @@ nativeCodeGen dflags h us cmms
ArchUnknown ->
panic "nativeCodeGen: No NCG for unknown arch"
--
-- Allocating more stack space for spilling is currently only
-- supported for the linear register allocator on x86/x86_64, the rest
-- default to the panic below. To support allocating extra stack on
-- more platforms provide a definition of ncgAllocMoreStack.
--
noAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr
noAllocMoreStack amount _
= panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\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"
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
......@@ -419,7 +440,7 @@ cmmNativeGen dflags ncgImpl us cmm count
= foldr (\r -> plusUFM_C unionUniqSets
$ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
emptyUFM
$ allocatableRegs ncgImpl platform
$ allocatableRegs ncgImpl
-- do the graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
......@@ -428,7 +449,7 @@ cmmNativeGen dflags ncgImpl us cmm count
$ Color.regAlloc
dflags
alloc_regs
(mkUniqSet [0 .. maxSpillSlots ncgImpl dflags])
(mkUniqSet [0 .. maxSpillSlots ncgImpl])
withLiveness
-- dump out what happened during register allocation
......@@ -457,11 +478,20 @@ cmmNativeGen dflags ncgImpl us cmm count
else do
-- do linear register allocation
let reg_alloc proc = do
(alloced, maybe_more_stack, ra_stats) <-
Linear.regAlloc dflags proc
case maybe_more_stack of
Nothing -> return ( alloced, ra_stats )
Just amount ->
return ( ncgAllocMoreStack ncgImpl amount alloced
, ra_stats )
let ((alloced, regAllocStats), usAlloc)
= {-# SCC "RegAlloc" #-}
initUs usLive
$ liftM unzip
$ mapM (Linear.regAlloc dflags) withLiveness
$ mapM reg_alloc withLiveness
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
......@@ -490,7 +520,7 @@ cmmNativeGen dflags ncgImpl us cmm count
---- generate jump tables
let tabled =
{-# SCC "generateJumpTables" #-}
generateJumpTables dflags ncgImpl kludged
generateJumpTables ncgImpl kludged
---- shortcut branches
let shorted =
......@@ -711,12 +741,12 @@ makeFarBranches blocks
-- Analyzes all native code and generates data sections for all jump
-- table instructions.
generateJumpTables
:: DynFlags -> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables dflags ncgImpl xs = concatMap f xs
:: NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables ncgImpl xs = concatMap f xs
where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
f p = [p]
g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl dflags) xs)
g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
-- -----------------------------------------------------------------------------
-- Shortcut branches
......
......@@ -163,3 +163,16 @@ class Instruction instr where
-> [instr]
-- Subtract an amount from the C stack pointer
mkStackAllocInstr
:: Platform -- TODO: remove (needed by x86/x86_64
-- because they share an Instr type)
-> Int
-> instr
-- Add an amount to the C stack pointer
mkStackDeallocInstr
:: Platform -- TODO: remove (needed by x86/x86_64
-- because they share an Instr type)
-> Int
-> instr
......@@ -64,6 +64,8 @@ instance Instruction Instr where
mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr
takeRegRegMoveInstr = ppc_takeRegRegMoveInstr
mkJumpInstr = ppc_mkJumpInstr
mkStackAllocInstr = panic "no ppc_mkStackAllocInstr"
mkStackDeallocInstr = panic "no ppc_mkStackDeallocInstr"
-- -----------------------------------------------------------------------------
......
......@@ -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)
......
......@@ -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
......@@ -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.
......
......@@ -108,6 +108,8 @@ instance Instruction Instr where
mkRegRegMoveInstr = sparc_mkRegRegMoveInstr
takeRegRegMoveInstr = sparc_takeRegRegMoveInstr
mkJumpInstr = sparc_mkJumpInstr
mkStackAllocInstr = panic "no sparc_mkStackAllocInstr"
mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr"
-- | SPARC instruction set.
......
......@@ -11,7 +11,7 @@
module X86.Instr (Instr(..), Operand(..),
getJumpDestBlockId, canShortcut, shortcutStatics,
shortcutJump, i386_insert_ffrees,
shortcutJump, i386_insert_ffrees, allocMoreStack,
maxSpillSlots, archWordSize)
where
......@@ -58,6 +58,8 @@ instance Instruction Instr where
mkRegRegMoveInstr = x86_mkRegRegMoveInstr
takeRegRegMoveInstr = x86_takeRegRegMoveInstr
mkJumpInstr = x86_mkJumpInstr
mkStackAllocInstr = x86_mkStackAllocInstr
mkStackDeallocInstr = x86_mkStackDeallocInstr
-- -----------------------------------------------------------------------------
......@@ -620,14 +622,13 @@ x86_mkSpillInstr
-> Instr
x86_mkSpillInstr dflags reg delta slot
= let off = spillSlotToOffset dflags slot
= let off = spillSlotToOffset dflags slot - delta
in
let off_w = (off - delta) `div` (if is32Bit then 4 else 8)
in case targetClassOfReg platform reg of
case targetClassOfReg platform reg of
RcInteger -> MOV (archWordSize is32Bit)
(OpReg reg) (OpAddr (spRel dflags off_w))
RcDouble -> GST FF80 reg (spRel dflags off_w) {- RcFloat/RcDouble -}
RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off_w))