diff options
Diffstat (limited to 'compiler/GHC.hs')
| -rw-r--r-- | compiler/GHC.hs | 66 |
1 files changed, 38 insertions, 28 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 7e882dbd8b..20f0ec633a 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -310,7 +310,8 @@ import GHC.Driver.Errors.Types import GHC.Driver.CmdLine import GHC.Driver.Session import GHC.Driver.Backend -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Hooks @@ -655,7 +656,7 @@ setSessionDynFlags dflags0 = do | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 - then return (logInfo logger dflags $ withPprStyle defaultDumpStyle msg) + then return (logInfo logger $ withPprStyle defaultDumpStyle msg) else return (pure ()) let conf = IServConfig @@ -687,13 +688,15 @@ setSessionDynFlags dflags0 = do , ue_units = unit_state , ue_unit_dbs = Just dbs } - modifySession $ \h -> h{ hsc_dflags = dflags - , hsc_IC = (hsc_IC h){ ic_dflags = dflags } + + modifySession $ \h -> hscSetFlags dflags $ + h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } , hsc_interp = hsc_interp h <|> interp -- we only update the interpreter if there wasn't -- already one set up , hsc_unit_env = unit_env } + invalidateModSummaryCache -- | Sets the program 'DynFlags'. Note: this invalidates the internal @@ -728,10 +731,9 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_units = unit_state , ue_unit_dbs = Just dbs } - modifySession $ \h -> h{ hsc_dflags = dflags1 - , hsc_unit_env = unit_env - } - else modifySession $ \h -> h{ hsc_dflags = dflags0 } + modifySession $ \h -> hscSetFlags dflags1 $ h{ hsc_unit_env = unit_env } + else modifySession (hscSetFlags dflags0) + when invalidate_needed $ invalidateModSummaryCache return changed @@ -806,7 +808,10 @@ parseDynamicFlags -> m (DynFlags, [Located String], [Warn]) parseDynamicFlags logger dflags cmdline = do (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline - dflags2 <- liftIO $ interpretPackageEnv logger dflags1 + -- flags that have just been read are used by the logger when loading package + -- env (this is checked by T16318) + let logger1 = setLogFlags logger (initLogFlags dflags1) + dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1 return (dflags2, leftovers, warns) -- | Parse command line arguments that look like files. @@ -1132,9 +1137,10 @@ getModSummary mod = do parseModule :: GhcMonad m => ModSummary -> m ParsedModule parseModule ms = do hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - hpm <- liftIO $ hscParse hsc_env_tmp ms - return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)) + liftIO $ do + let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env + hpm <- hscParse lcl_hsc_env ms + return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)) -- See Note [exact print annotations] in GHC.Parser.Annotation -- | Typecheck and rename a parsed module. @@ -1142,17 +1148,20 @@ parseModule ms = do -- Throws a 'SourceError' if either fails. typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule pmod = do - let ms = modSummary pmod hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, rn_info) - <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod } - details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env - safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env - - return $ + + liftIO $ do + let ms = modSummary pmod + let lcl_dflags = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.) + let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env + let lcl_logger = hsc_logger lcl_hsc_env + (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod } + details <- makeSimpleDetails lcl_logger tc_gbl_env + safe <- finalSafeMode lcl_dflags tc_gbl_env + + return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), tm_parsed_module = pmod, @@ -1172,12 +1181,13 @@ typecheckModule pmod = do -- | Desugar a typechecked module. desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule tcm = do - let ms = modSummary tcm - let (tcg, _) = tm_internals tcm hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg - return $ + liftIO $ do + let ms = modSummary tcm + let (tcg, _) = tm_internals tcm + let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env + guts <- hscDesugar lcl_hsc_env ms tcg + return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts @@ -1825,7 +1835,7 @@ interpretPackageEnv logger dflags = do return dflags Just envfile -> do content <- readFile envfile - compilationProgressMsg logger dflags (text "Loaded package environment from " <> text envfile) + compilationProgressMsg logger (text "Loaded package environment from " <> text envfile) let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags return dflags' |