From a2dcad4e6f75c08aacc5902a20ca4c773819d7b7 Mon Sep 17 00:00:00 2001 From: Andre Marianiello Date: Thu, 5 May 2022 20:40:31 -0400 Subject: Decouple dynflags in Cmm parser (related to #17957) --- compiler/GHC/Cmm/Parser.y | 36 ++++++++++++------------- compiler/GHC/Cmm/Parser/Monad.hs | 16 +++++++---- compiler/GHC/Driver/Config/Cmm/Parser.hs | 27 +++++++++++++++++++ compiler/GHC/Driver/Main.hs | 7 +++-- compiler/ghc.cabal.in | 1 + testsuite/tests/regalloc/regalloc_unit_tests.hs | 6 ++++- 6 files changed, 67 insertions(+), 26 deletions(-) create mode 100644 compiler/GHC/Driver/Config/Cmm/Parser.hs 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 -- cgit v1.2.1