Decouple dynflags in Cmm parser (related to #17957)

6 files changed, 67 insertions, 26 deletions

diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 100e4f9b65..7150ca9b92 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -200,16 +200,11 @@ necessary to the stack to accommodate it (e.g. 2).
 {
 {-# LANGUAGE TupleSections #-}
 
-module GHC.Cmm.Parser ( parseCmmFile ) where
+module GHC.Cmm.Parser ( parseCmmFile, CmmParserConfig(..) ) where
 
 import GHC.Prelude
 import qualified Prelude -- for happy-generated code
 
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Config.Parser (initParserOpts)
-import GHC.Driver.Config.StgToCmm
-
 import GHC.Platform
 import GHC.Platform.Profile
 
@@ -929,8 +924,9 @@ nameToMachOp name =
 
 exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
 exprOp name args_code = do
-  profile     <- PD.getProfile
-  align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags
+  pdc     <- PD.getPDConfig
+  let profile = PD.pdProfile pdc
+  let align_check = PD.pdSanitizeAlignment pdc
   case lookupUFM (exprMacros profile align_check) name of
      Just f  -> return $ do
         args <- sequence args_code
@@ -1496,39 +1492,43 @@ initEnv profile = listToUFM [
   ]
   where platform = profilePlatform profile
 
+data CmmParserConfig = CmmParserConfig
+  { cmmpParserOpts :: !ParserOpts
+  , cmmpPDConfig :: !PDConfig
+  , cmmpStgToCmmConfig :: !StgToCmmConfig
+  }
 
-parseCmmFile :: DynFlags
+parseCmmFile :: CmmParserConfig
              -> Module
              -> HomeUnit
              -> FilePath
              -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))
-parseCmmFile dflags this_mod home_unit filename = do
+parseCmmFile cmmpConfig this_mod home_unit filename = do
   buf <- hGetStringBuffer filename
   let
         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
-        opts       = initParserOpts dflags
-        init_state = (initParserState opts buf init_loc) { lex_state = [0] }
+        init_state = (initParserState (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] }
                 -- reset the lex_state: the Lexer monad leaves some stuff
                 -- in there we don't want.
-  case unPD cmmParse dflags home_unit init_state of
+        pdConfig = cmmpPDConfig cmmpConfig
+  case unPD cmmParse pdConfig home_unit init_state of
     PFailed pst -> do
         let (warnings,errors) = getPsMessages pst
         return (warnings, errors, Nothing)
     POk pst code -> do
         st <- initC
-        let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)
+        let fstate = F.initFCodeState (profilePlatform $ pdProfile pdConfig)
         let fcode = do
-              ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()
+              ((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return ()
               -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)
               let used_info = map (cmmInfoTableToInfoProvEnt this_mod)
                                               (mapMaybe topInfoTable cmm)
               ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info
               return (cmm ++ cmm2, used_info)
-            (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode
+            (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode
             (warnings,errors) = getPsMessages pst
         if not (isEmptyMessages errors)
          then return (warnings, errors, Nothing)
          else return (warnings, errors, Just cmm)
-  where
-        no_module = panic "parseCmmFile: no module"
+
 }
diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs
index e7d763497a..b13321d491 100644
--- a/compiler/GHC/Cmm/Parser/Monad.hs
+++ b/compiler/GHC/Cmm/Parser/Monad.hs
@@ -11,9 +11,11 @@ module GHC.Cmm.Parser.Monad (
     PD(..)
   , liftP
   , failMsgPD
+  , getPDConfig
   , getProfile
   , getPlatform
   , getHomeUnitId
+  , PDConfig(..)
   ) where
 
 import GHC.Prelude
@@ -23,7 +25,6 @@ import GHC.Platform.Profile
 
 import Control.Monad
 
-import GHC.Driver.Session
 import GHC.Parser.Lexer
 import GHC.Parser.Errors.Types
 import GHC.Types.Error ( MsgEnvelope )
@@ -31,7 +32,12 @@ import GHC.Types.SrcLoc
 import GHC.Unit.Types
 import GHC.Unit.Home
 
-newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a }
+data PDConfig = PDConfig
+  { pdProfile :: !Profile
+  , pdSanitizeAlignment :: !Bool -- ^ Insert alignment checks (cf @-falignment-sanitisation@)
+  }
+
+newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a }
 
 instance Functor PD where
   fmap = liftM
@@ -58,11 +64,11 @@ thenPD :: PD a -> (a -> PD b) -> PD b
                 POk s1 a   -> unPD (k a) d hu s1
                 PFailed s1 -> PFailed s1
 
-instance HasDynFlags PD where
-   getDynFlags = PD $ \d _ s -> POk s d
+getPDConfig :: PD PDConfig
+getPDConfig = PD $ \pdc _ s -> POk s pdc
 
 getProfile :: PD Profile
-getProfile = targetProfile <$> getDynFlags
+getProfile = PD $ \pdc _ s -> POk s (pdProfile pdc)
 
 getPlatform :: PD Platform
 getPlatform = profilePlatform <$> getProfile
diff --git a/compiler/GHC/Driver/Config/Cmm/Parser.hs b/compiler/GHC/Driver/Config/Cmm/Parser.hs
new file mode 100644
index 0000000000..3749bfd87c
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Cmm/Parser.hs
@@ -0,0 +1,27 @@
+module GHC.Driver.Config.Cmm.Parser
+  ( initCmmParserConfig
+  ) where
+
+import GHC.Cmm.Parser
+import GHC.Cmm.Parser.Monad
+
+import GHC.Driver.Config.Parser
+import GHC.Driver.Config.StgToCmm
+import GHC.Driver.Session
+
+import GHC.Unit.Types
+
+
+initPDConfig :: DynFlags -> PDConfig
+initPDConfig dflags = PDConfig
+  { pdProfile = targetProfile dflags
+  , pdSanitizeAlignment = gopt Opt_AlignmentSanitisation dflags
+  }
+
+initCmmParserConfig :: DynFlags -> Module -> CmmParserConfig
+initCmmParserConfig dflags mod = CmmParserConfig
+  { cmmpParserOpts = initParserOpts dflags
+  , cmmpPDConfig = initPDConfig dflags
+  , cmmpStgToCmmConfig = initStgToCmmConfig dflags mod
+  }
+
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index b1f2b2bdac..2e42a9767a 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -106,6 +106,7 @@ import GHC.Driver.Env
 import GHC.Driver.Errors
 import GHC.Driver.Errors.Types
 import GHC.Driver.CodeOutput
+import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)
 import GHC.Driver.Config.Logger   (initLogFlags)
 import GHC.Driver.Config.Parser   (initParserOpts)
 import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)
@@ -180,10 +181,10 @@ import qualified GHC.StgToCmm as StgToCmm ( codeGen )
 import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
 
 import GHC.Cmm
-import GHC.Cmm.Parser       ( parseCmmFile )
 import GHC.Cmm.Info.Build
 import GHC.Cmm.Pipeline
 import GHC.Cmm.Info
+import GHC.Cmm.Parser
 
 import GHC.Unit
 import GHC.Unit.Env
@@ -1745,10 +1746,12 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
         -- lest we reproduce #11784.
         mod_name = mkModuleName $ "Cmm$" ++ original_filename
         cmm_mod = mkHomeModule home_unit mod_name
+        no_module = panic "hscCompileCmmFile: no module"
+        cmmpConfig = initCmmParserConfig dflags no_module
     (cmm, ents) <- ioMsgMaybe
                $ do
                   (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
-                                       $ parseCmmFile dflags cmm_mod home_unit filename
+                                       $ parseCmmFile cmmpConfig cmm_mod home_unit filename
                   let msgs = warns `unionMessages` errs
                   return (GhcPsMessage <$> msgs, cmm)
     liftIO $ do
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index f4c1a41dd3..fda4e5e363 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -383,6 +383,7 @@ Library
         GHC.Driver.CodeOutput
         GHC.Driver.Config
         GHC.Driver.Config.Cmm
+        GHC.Driver.Config.Cmm.Parser
         GHC.Driver.Config.CmmToAsm
         GHC.Driver.Config.CmmToLlvm
         GHC.Driver.Config.Diagnostic
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index 8e9721ec2e..04e59a9ce9 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -24,6 +24,7 @@ import qualified GHC.CmmToAsm.Reg.Graph.Stats as Color
 import qualified GHC.CmmToAsm.Reg.Linear.Base as Linear
 import qualified GHC.CmmToAsm.X86.Instr as X86.Instr
 import qualified GHC.CmmToAsm.X86 as X86
+import GHC.Driver.Config.Cmm.Parser
 import GHC.Driver.Config.CmmToAsm
 import GHC.Driver.Main
 import GHC.Driver.Env
@@ -48,6 +49,7 @@ import GHC.Driver.Errors
 import GHC.Utils.Error
 import GHC.Utils.Logger
 import GHC.Utils.Outputable
+import GHC.Utils.Panic
 import GHC.Types.Basic
 import GHC.Unit.Home
 import GHC.Unit.Finder
@@ -131,7 +133,9 @@ compileCmmForRegAllocStats logger dflags cmmFile ncgImplF us = do
 
     -- parse the cmm file and output any warnings or errors
     let fake_mod = mkHomeModule (hsc_home_unit hscEnv) (mkModuleName "fake")
-    (warnings, errors, parsedCmm) <- parseCmmFile dflags fake_mod (hsc_home_unit hscEnv) cmmFile
+        no_module = panic "compileCmmForRegAllocStats: no module"
+        cmmpConfig = initCmmParserConfig dflags no_module
+    (warnings, errors, parsedCmm) <- parseCmmFile cmmpConfig fake_mod (hsc_home_unit hscEnv) cmmFile
 
     -- print parser errors or warnings
     let !diag_opts = initDiagOpts dflags