Commit 2e3c9255 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Put DynFlags into the RegM monad

Also moved the type definition into RegAlloc.Linear.State to de-orphan
the Monad instance.
parent 2115585f
......@@ -13,7 +13,6 @@ module RegAlloc.Linear.Base (
-- the allocator monad
RA_State(..),
RegM(..)
)
where
......@@ -22,6 +21,7 @@ import RegAlloc.Linear.StackMap
import RegAlloc.Liveness
import Reg
import DynFlags
import Outputable
import Unique
import UniqFM
......@@ -126,11 +126,7 @@ data RA_State freeRegs
-- | Record why things were spilled, for -ddrop-asm-stats.
-- Just keep a list here instead of a map of regs -> reasons.
-- We don't want to slow down the allocator if we're not going to emit the stats.
, ra_spills :: [SpillReason] }
-- | The register allocator monad type.
newtype RegM freeRegs a
= RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }
, ra_spills :: [SpillReason]
, ra_DynFlags :: DynFlags }
......@@ -189,27 +189,28 @@ linearRegAlloc
linearRegAlloc dflags first_id block_live sccs
= let platform = targetPlatform dflags
in case platformArch platform of
ArchX86 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs
ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs platform :: X86_64.FreeRegs) first_id block_live sccs
ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs
ArchPPC -> linearRegAlloc' platform (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs
ArchX86 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs
ArchX86_64 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86_64.FreeRegs) first_id block_live sccs
ArchSPARC -> linearRegAlloc' dflags (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs
ArchPPC -> linearRegAlloc' dflags (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs
ArchARM _ _ _ -> panic "linearRegAlloc ArchARM"
ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64"
ArchUnknown -> panic "linearRegAlloc ArchUnknown"
linearRegAlloc'
:: (FR freeRegs, Outputable instr, Instruction instr)
=> Platform
=> DynFlags
-> freeRegs
-> 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)
linearRegAlloc' platform initFreeRegs first_id block_live sccs
linearRegAlloc' dflags initFreeRegs first_id block_live sccs
= do us <- getUs
let (_, _, stats, blocks) =
runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us
let platform = targetPlatform dflags
(_, _, stats, blocks) =
runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us
$ linearRA_SCCs platform first_id block_live [] sccs
return (blocks, stats)
......
......@@ -3,8 +3,6 @@
-- Here we keep all the state that the register allocator keeps track
-- of as it walks the instructions in a basic block.
{-# OPTIONS_GHC -fno-warn-orphans #-}
module RegAlloc.Linear.State (
RA_State(..),
RegM,
......@@ -38,19 +36,29 @@ import RegAlloc.Liveness
import Instruction
import Reg
import DynFlags
import Platform
import Unique
import UniqSupply
-- | The register allocator monad type.
newtype RegM freeRegs a
= RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }
-- | The RegM Monad
instance Monad (RegM freeRegs) where
m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
return a = RegM $ \s -> (# s, a #)
instance HasDynFlags (RegM a) where
getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)
-- | Run a computation in the RegM register allocator monad.
runR :: BlockAssignment freeRegs
runR :: DynFlags
-> BlockAssignment freeRegs
-> freeRegs
-> RegMap Loc
-> StackMap
......@@ -58,7 +66,7 @@ runR :: BlockAssignment freeRegs
-> RegM freeRegs a
-> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
runR block_assig freeregs assig stack us thing =
runR dflags block_assig freeregs assig stack us thing =
case unReg thing
(RA_State
{ ra_blockassig = block_assig
......@@ -67,7 +75,8 @@ runR block_assig freeregs assig stack us thing =
, ra_delta = 0{-???-}
, ra_stack = stack
, ra_us = us
, ra_spills = [] })
, ra_spills = []
, ra_DynFlags = dflags })
of
(# state'@RA_State
{ ra_blockassig = block_assig
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment