Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/2e3c925564b6c08bb187c747c806ccd2528ccbb9 >--------------------------------------------------------------- commit 2e3c925564b6c08bb187c747c806ccd2528ccbb9 Author: Ian Lynagh <[email protected]> Date: Fri Sep 14 19:39:28 2012 +0100 Put DynFlags into the RegM monad Also moved the type definition into RegAlloc.Linear.State to de-orphan the Monad instance. >--------------------------------------------------------------- compiler/nativeGen/RegAlloc/Linear/Base.hs | 10 +++------- compiler/nativeGen/RegAlloc/Linear/Main.hs | 17 +++++++++-------- compiler/nativeGen/RegAlloc/Linear/State.hs | 19 ++++++++++++++----- 3 files changed, 26 insertions(+), 20 deletions(-) diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs index 432acdf..e583313 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Base.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -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 } diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index bf0f5aa..0c68048 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -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) diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index 57b8991..433bb05 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
