[commit: ghc] master: Put DynFlags into the RegM monad (2e3c925)

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