diff options
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 10 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 35 | ||||
| -rw-r--r-- | compiler/main/GhcMonad.hs | 10 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 2 |
4 files changed, 44 insertions, 13 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 539e2220b7..0aec7ad2a3 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -275,7 +275,7 @@ genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do -- some extra parameters. genCall t@(PrimTarget op) [] args | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do - dflags <- lift $ getDynFlags + dflags <- getDynFlags let isVolTy = [i1] isVolVal = [mkIntLit i1 0] argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy @@ -377,7 +377,7 @@ genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] = -- Handle all other foreign calls and prim ops. genCall target res args = runStmtsDecls $ do - dflags <- lift $ getDynFlags + dflags <- getDynFlags -- parameter types let arg_type (_, AddrHint) = i8Ptr @@ -1378,7 +1378,7 @@ genMachOp_slow opt op [x, y] = case op of else do -- Error. Continue anyway so we can debug the generated ll file. - dflags <- lift getDynFlags + dflags <- getDynFlags let style = mkCodeStyle CStyle toString doc = renderWithStyle dflags doc style cmmToStr = (lines . toString . PprCmm.pprExpr) @@ -1422,7 +1422,7 @@ genMachOp_slow opt op [x, y] = case op of vx <- exprToVarW x vy <- exprToVarW y - dflags <- lift getDynFlags + dflags <- getDynFlags let word = getVarType vx let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) let shift = llvmWidthInBits dflags word @@ -1522,7 +1522,7 @@ genLoad_fast atomic e r n ty = do genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData genLoad_slow atomic e ty meta = runExprData $ do iptr <- exprToVarW e - dflags <- lift getDynFlags + dflags <- getDynFlags case getVarType iptr of LMPointer _ -> do doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3d99a1a5c0..c492a01332 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------- -- @@ -176,6 +177,13 @@ import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef import Control.Arrow ((&&&)) import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.Maybe as CMT +#if MIN_VERSION_transformers(4,0,0) +import Control.Monad.Trans.Except +#endif import Control.Exception (throwIO) import Data.Bits @@ -186,6 +194,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import Data.Monoid (Monoid) import Data.Word import System.FilePath import System.Directory @@ -912,6 +921,32 @@ data DynFlags = DynFlags { class HasDynFlags m where getDynFlags :: m DynFlags +{- It would be desirable to have the more generalised + + instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where + getDynFlags = lift getDynFlags + +instance definition. However, that definition would overlap with the +`HasDynFlags (GhcT m)` instance. Instead we define instances for a +couple of common Monad transformers explicitly. -} + +instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where + getDynFlags = liftMaybeT getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (CMT.MaybeT m) where + getDynFlags = lift getDynFlags + +#if MIN_VERSION_transformers(4,0,0) +instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where + getDynFlags = lift getDynFlags +#endif + class ContainsDynFlags t where extractDynFlags :: t -> DynFlags replaceDynFlags :: t -> DynFlags -> t diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 44f9effdaa..34d5bcf91f 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -29,6 +29,7 @@ import DynFlags import Exception import ErrUtils +import Control.Monad import Data.IORef -- ----------------------------------------------------------------------------- @@ -184,13 +185,8 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where in unGhcT (f g_restore) s -#if __GLASGOW_HASKELL__ < 710 --- Pre-AMP change -instance (ExceptionMonad m, Functor m) => HasDynFlags (GhcT m) where -#else -instance (ExceptionMonad m) => HasDynFlags (GhcT m) where -#endif - getDynFlags = getSessionDynFlags +instance MonadIO m => HasDynFlags (GhcT m) where + getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) #if __GLASGOW_HASKELL__ < 710 -- Pre-AMP change diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 02a8670ef1..7fd9c8b1ab 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -849,7 +849,7 @@ runOneCommand eh gCmd = do checkInputForLayout :: String -> InputT GHCi (Maybe String) -> InputT GHCi (Maybe String) checkInputForLayout stmt getStmt = do - dflags' <- lift $ getDynFlags + dflags' <- getDynFlags let dflags = xopt_set dflags' Opt_AlternativeLayoutRule st0 <- getGHCiState let buf' = stringToStringBuffer stmt |