diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2021-05-21 16:51:59 +0200 |
|---|---|---|
| committer | Sylvain Henry <sylvain@haskus.fr> | 2021-06-07 10:35:39 +0200 |
| commit | 4dc681c7c0345ee8ae268749d98b419dabf6a3bc (patch) | |
| tree | ab05546d61b2d90f2fc9e652a13da48ce89096ae | |
| parent | 5e1a224435fc6ebd34d02566f17fe1eaf5475bab (diff) | |
| download | haskell-4dc681c7c0345ee8ae268749d98b419dabf6a3bc.tar.gz | |
Make Logger independent of DynFlags
Introduce LogFlags as a independent subset of DynFlags used for logging.
As a consequence in many places we don't have to pass both Logger and
DynFlags anymore.
The main reason for this refactoring is that I want to refactor the
systools interfaces: for now many systools functions use DynFlags both
to use the Logger and to fetch their parameters (e.g. ldInputs for the
linker). I'm interested in refactoring the way they fetch their
parameters (i.e. use dedicated XxxOpts data types instead of DynFlags)
for #19877. But if I did this refactoring before refactoring the Logger,
we would have duplicate parameters (e.g. ldInputs from DynFlags and
linkerInputs from LinkerOpts). Hence this patch first.
Some flags don't really belong to LogFlags because they are subsystem
specific (e.g. most DumpFlags). For example -ddump-asm should better be
passed in NCGConfig somehow. This patch doesn't fix this tight coupling:
the dump flags are part of the UI but they are passed all the way down
for example to infer the file name for the dumps.
Because LogFlags are a subset of the DynFlags, we must update the former
when the latter changes (not so often). As a consequence we now use
accessors to read/write DynFlags in HscEnv instead of using `hsc_dflags`
directly.
In the process I've also made some subsystems less dependent on DynFlags:
- CmmToAsm: by passing some missing flags via NCGConfig (see new fields
in GHC.CmmToAsm.Config)
- Core.Opt.*:
- by passing -dinline-check value into UnfoldingOpts
- by fixing some Core passes interfaces (e.g. CallArity, FloatIn)
that took DynFlags argument for no good reason.
- as a side-effect GHC.Core.Opt.Pipeline.doCorePass is much less
convoluted.
89 files changed, 1378 insertions, 1365 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' diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index fa8cc27e1b..1c6dc351b8 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -46,7 +46,6 @@ import GHC.Cmm.Dataflow.Collections import GHC.Platform import GHC.Platform.Profile import GHC.Data.Maybe -import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -67,20 +66,19 @@ mkEmptyContInfoTable info_lbl , cit_srt = Nothing , cit_clo = Nothing } -cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a +cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a) -cmmToRawCmm logger dflags cmms +cmmToRawCmm logger profile cmms = do { ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl] do_one cmm = do uniqs <- mkSplitUniqSupply 'i' -- NB. strictness fixes a space leak. DO NOT REMOVE. - withTimingSilent logger dflags (text "Cmm -> Raw Cmm") - (\x -> seqList x ()) + withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ()) -- TODO: It might be better to make `mkInfoTable` run in -- IO as well so we don't have to pass around -- a UniqSupply (see #16843) - (return $ initUs_ uniqs $ concatMapM (mkInfoTable dflags) cmm) + (return $ initUs_ uniqs $ concatMapM (mkInfoTable profile) cmm) ; return (Stream.mapM do_one cmms) } @@ -118,15 +116,15 @@ cmmToRawCmm logger dflags cmms -- -- * The SRT slot is only there if there is SRT info to record -mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl] +mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) +mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks) -- -- in the non-tables-next-to-code case, procs can have at most a -- single info table associated with the entry label of the proc. -- - | not (platformTablesNextToCode (targetPlatform dflags)) + | not (platformTablesNextToCode platform) = case topInfoTable proc of -- must be at most one -- no info table Nothing -> @@ -134,7 +132,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) Just info@CmmInfoTable { cit_lbl = info_lbl } -> do (top_decls, (std_info, extra_bits)) <- - mkInfoTableContents dflags info Nothing + mkInfoTableContents profile info Nothing let rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits @@ -161,10 +159,10 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) where - platform = targetPlatform dflags + platform = profilePlatform profile do_one_info (lbl,itbl) = do (top_decls, (std_info, extra_bits)) <- - mkInfoTableContents dflags itbl Nothing + mkInfoTableContents profile itbl Nothing let info_lbl = cit_lbl itbl rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info @@ -178,20 +176,20 @@ type InfoTableContents = ( [CmmLit] -- The standard part , [CmmLit] ) -- The "extra bits" -- These Lits have *not* had mkRelativeTo applied to them -mkInfoTableContents :: DynFlags +mkInfoTableContents :: Profile -> CmmInfoTable -> Maybe Int -- Override default RTS type tag? -> UniqSM ([RawCmmDecl], -- Auxiliary top decls InfoTableContents) -- Info tbl + extra bits -mkInfoTableContents dflags +mkInfoTableContents profile info@(CmmInfoTable { cit_lbl = info_lbl , cit_rep = smrep , cit_prof = prof , cit_srt = srt }) mb_rts_tag | RTSRep rts_tag rep <- smrep - = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) + = mkInfoTableContents profile info{cit_rep = rep} (Just rts_tag) -- Completely override the rts_tag that mkInfoTableContents would -- otherwise compute, with the rts_tag stored in the RTSRep -- (which in turn came from a handwritten .cmm file) @@ -199,9 +197,9 @@ mkInfoTableContents dflags | StackRep frame <- smrep = do { (prof_lits, prof_data) <- mkProfLits platform prof ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt - ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame + ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame ; let - std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit + std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap liveness_lit rts_tag | Just tag <- mb_rts_tag = tag | null liveness_data = rET_SMALL -- Fits in extra_bits | otherwise = rET_BIG -- Does not; extra_bits is @@ -214,13 +212,13 @@ mkInfoTableContents dflags ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label - ; let std_info = mkStdInfoTable dflags prof_lits + ; let std_info = mkStdInfoTable profile prof_lits (mb_rts_tag `orElse` rtsClosureType smrep) (mb_srt_field `orElse` srt_bitmap) (mb_layout `orElse` layout) ; return (prof_data ++ ct_data, (std_info, extra_bits)) } where - platform = targetPlatform dflags + platform = profilePlatform profile mk_pieces :: ClosureTypeInfo -> [CmmLit] -> UniqSM ( Maybe CmmLit -- Override the SRT field with this , Maybe CmmLit -- Override the layout field with this @@ -245,7 +243,7 @@ mkInfoTableContents dflags ; return (Nothing, Nothing, extra_bits, []) } mk_pieces (Fun arity (ArgGen arg_bits)) srt_label - = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits + = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits ; let fun_type | null liveness_data = aRG_GEN | otherwise = aRG_GEN_BIG extra_bits = [ packIntsCLit platform fun_type arity ] @@ -343,12 +341,12 @@ makeRelativeRefTo platform info_lbl lit -- The head of the stack layout is the top of the stack and -- the least-significant bit. -mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) +mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) -- ^ Returns: -- 1. The bitmap (literal value or label) -- 2. Large bitmap CmmData if needed -mkLivenessBits dflags liveness +mkLivenessBits platform liveness | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word = do { uniq <- getUniqueM ; let bitmap_lbl = mkBitmapLabel uniq @@ -358,7 +356,6 @@ mkLivenessBits dflags liveness | otherwise -- Fits in one word = return (mkStgWordCLit platform bitmap_word, []) where - platform = targetPlatform dflags n_bits = length liveness bitmap :: Bitmap @@ -390,14 +387,14 @@ mkLivenessBits dflags liveness -- so we can't use constant offsets from Constants mkStdInfoTable - :: DynFlags + :: Profile -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) -> Int -- Closure RTS tag -> CmmLit -- SRT length -> CmmLit -- layout field -> [CmmLit] -mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit +mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit = -- Parallel revertible-black hole field prof_info -- Ticky info (none at present) @@ -405,9 +402,9 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit ++ [layout_lit, tag, srt] where - platform = targetPlatform dflags + platform = profilePlatform profile prof_info - | sccProfilingEnabled dflags = [type_descr, closure_descr] + | profileIsProfiling profile = [type_descr, closure_descr] | otherwise = [] tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform) diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 1d3431c4af..ab0c32996e 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -41,7 +41,7 @@ import GHC.Runtime.Heap.Layout import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap -import GHC.CmmToAsm +import GHC.Driver.Config.CmmToAsm import Control.Monad import Data.Map.Strict (Map) diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index b8a6f7de7c..a26fb4edba 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -205,6 +205,10 @@ module GHC.Cmm.Parser ( parseCmmFile ) 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.Platform import GHC.Platform.Profile @@ -251,9 +255,6 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.SrcLoc import GHC.Types.Tickish ( GenTickish(SourceNote) ) -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config import GHC.Utils.Error import GHC.Data.StringBuffer import GHC.Data.FastString diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index b508b5a265..481f2bb545 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -46,20 +46,20 @@ cmmPipeline hsc_env srtInfo prog = do let logger = hsc_logger hsc_env let dflags = hsc_dflags hsc_env let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group - withTimingSilent logger dflags (text "Cmm pipeline") forceRes $ do - tops <- {-# SCC "tops" #-} mapM (cpsTop logger dflags) prog + let platform = targetPlatform dflags + withTimingSilent logger (text "Cmm pipeline") forceRes $ do + tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform dflags) prog let (procs, data_) = partitionEithers tops (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_ - let platform = targetPlatform dflags - dumpWith logger dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) + dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) -cpsTop :: Logger -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) -cpsTop _logger dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p)) -cpsTop logger dflags proc = +cpsTop :: Logger -> Platform -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) +cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p)) +cpsTop logger platform dflags proc = do ----------- Control-flow optimisations ---------------------------------- @@ -96,7 +96,7 @@ cpsTop logger dflags proc = then do pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ minimalProcPointSet platform call_pps g - dumpWith logger dflags Opt_D_dump_cmm_proc "Proc points" + dumpWith logger Opt_D_dump_cmm_proc "Proc points" FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g) return pp else @@ -117,14 +117,14 @@ cpsTop logger dflags proc = ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g - dumpWith logger dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) + dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) g <- if splitting_proc_points then do ------------- Split into separate procedures ----------------------- let pp_map = {-# SCC "procPointAnalysis" #-} procPointAnalysis proc_points g - dumpWith logger dflags Opt_D_dump_cmm_procmap "procpoint map" + dumpWith logger Opt_D_dump_cmm_procmap "procpoint map" FormatCMM (ppr pp_map) g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ splitAtProcPoints platform l call_pps proc_points pp_map @@ -151,11 +151,10 @@ cpsTop logger dflags proc = return (Left (cafEnv, g)) - where platform = targetPlatform dflags - dump = dumpGraph logger dflags + where dump = dumpGraph logger platform dflags dumps flag name - = mapM_ (dumpWith logger dflags flag name FormatCMM . pdoc platform) + = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform) condPass flag pass g dumpflag dumpname = if gopt flag dflags @@ -348,24 +347,23 @@ runUniqSM m = do return (initUs_ us m) -dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO () -dumpGraph logger dflags flag name g = do +dumpGraph :: Logger -> Platform -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph logger platform dflags flag name g = do when (gopt Opt_DoCmmLinting dflags) $ do_lint g - dumpWith logger dflags flag name FormatCMM (pdoc platform g) + dumpWith logger flag name FormatCMM (pdoc platform g) where - platform = targetPlatform dflags do_lint g = case cmmLintGraph platform g of - Just err -> do { fatalErrorMsg logger dflags err - ; ghcExit logger dflags 1 + Just err -> do { fatalErrorMsg logger err + ; ghcExit logger 1 } Nothing -> return () -dumpWith :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -dumpWith logger dflags flag txt fmt sdoc = do - dumpIfSet_dyn logger dflags flag txt fmt sdoc - when (not (dopt flag dflags)) $ +dumpWith :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpWith logger flag txt fmt sdoc = do + putDumpFileMaybe logger flag txt fmt sdoc + when (not (logHasDumpFlag logger flag)) $ -- If `-ddump-cmm-verbose -ddump-to-file` is specified, -- dump each Cmm pipeline stage output to a separate file. #16930 - when (dopt Opt_D_dump_cmm_verbose dflags) - $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) flag txt fmt sdoc - dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc + when (logHasDumpFlag logger Opt_D_dump_cmm_verbose) + $ logDumpFile logger (mkDumpStyle alwaysQualify) flag txt fmt sdoc + putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 82122911b6..f28403e9b8 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -75,7 +75,6 @@ module GHC.CmmToAsm -- cmmNativeGen emits , cmmNativeGen , NcgImpl(..) - , initNCGConfig ) where @@ -149,15 +148,14 @@ import Control.Monad import System.IO -------------------- -nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply +nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen logger dflags this_mod modLoc h us cmms - = let config = initNCGConfig dflags this_mod - platform = ncgPlatform config +nativeCodeGen logger config modLoc h us cmms + = let platform = ncgPlatform config nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a - nCG' ncgImpl = nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms + nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h us cmms in case platformArch platform of ArchX86 -> nCG' (X86.ncgX86 config) ArchX86_64 -> nCG' (X86.ncgX86_64 config) @@ -221,7 +219,6 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => Logger - -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -229,35 +226,34 @@ nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instructio -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms +nativeCodeGen' logger config modLoc ncgImpl h us cmms = do -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty - (ngs, us', a) <- cmmNativeGenStream logger dflags config modLoc ncgImpl bufh us + (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us cmms ngs0 - _ <- finishNativeGen logger dflags config modLoc bufh us' ngs + _ <- finishNativeGen logger config modLoc bufh us' ngs return a finishNativeGen :: Instruction instr => Logger - -> DynFlags -> NCGConfig -> ModLocation -> BufHandle -> UniqSupply -> NativeGenAcc statics instr -> IO UniqSupply -finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs - = withTimingSilent logger dflags (text "NCG") (`seq` ()) $ do +finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs + = withTimingSilent logger (text "NCG") (`seq` ()) $ do -- Write debug data and finish us' <- if not (ncgDwarfEnabled config) then return us else do (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs) - emitNativeCode logger dflags config bufh dwarf + emitNativeCode logger config bufh dwarf return us' bFlush bufh @@ -274,7 +270,7 @@ finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs dump_stats (Color.pprStats stats graphGlobal) let platform = ncgPlatform config - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_conflicts "Register conflict graph" FormatText $ Color.dotGraph @@ -296,13 +292,12 @@ finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs $ makeImportsDoc config (concat (ngs_imports ngs)) return us' where - dump_stats = putDumpMsg logger dflags (mkDumpStyle alwaysQualify) + dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify) Opt_D_dump_asm_stats "NCG stats" FormatText cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => Logger - -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -312,7 +307,7 @@ cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform st -> NativeGenAcc statics instr -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs +cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs = loop us (Stream.runStream cmm_stream) ngs where ncglabel = text "NCG" @@ -334,7 +329,6 @@ cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs Stream.Yield cmms cmm_stream' -> do (us', ngs'') <- withTimingSilent logger - dflags ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do -- Generate debug information let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms @@ -342,15 +336,15 @@ cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs dbgMap = debugToMap ndbgs -- Generate native code - (ngs',us') <- cmmNativeGens logger dflags config modLoc ncgImpl h + (ngs',us') <- cmmNativeGens logger config modLoc ncgImpl h dbgMap us cmms ngs 0 -- Link native code information into debug blocks -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs - platform = targetPlatform dflags + platform = ncgPlatform config unless (null ldbgs) $ - dumpIfSet_dyn logger dflags Opt_D_dump_debug "Debug Infos" FormatText + putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText (vcat $ map (pdoc platform) ldbgs) -- Accumulate debug information for emission in finishNativeGen. @@ -365,7 +359,6 @@ cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs cmmNativeGens :: forall statics instr jumpDest. (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => Logger - -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -377,7 +370,7 @@ cmmNativeGens :: forall statics instr jumpDest. -> Int -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go +cmmNativeGens logger config modLoc ncgImpl h dbgMap = go where go :: UniqSupply -> [RawCmmDecl] -> NativeGenAcc statics instr -> Int @@ -390,7 +383,7 @@ cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go let fileIds = ngs_dwarfFiles ngs (us', fileIds', native, imports, colorStats, linearStats, unwinds) <- {-# SCC "cmmNativeGen" #-} - cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap + cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count -- Generate .file directives for every new file that has been @@ -402,17 +395,17 @@ cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go pprDecl (f,n) = text "\t.file " <> ppr n <+> pprFilePathString (unpackFS f) - emitNativeCode logger dflags config h $ vcat $ + emitNativeCode logger config h $ vcat $ map pprDecl newFileIds ++ map (pprNatCmmDecl ncgImpl) native -- force evaluation all this stuff to avoid space leaks - let platform = targetPlatform dflags - {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map (pdoc platform) imports) () + let platform = ncgPlatform config + {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pdoc platform) imports) () let !labels' = if ncgDwarfEnabled config then cmmDebugLabels isMetaInstr native else [] - !natives' = if dopt Opt_D_dump_asm_stats dflags + !natives' = if logHasDumpFlag logger Opt_D_dump_asm_stats then native : ngs_natives ngs else [] mCon = maybe id (:) @@ -427,14 +420,14 @@ cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go go us' cmms ngs' (count + 1) -emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO () -emitNativeCode logger dflags config h sdoc = do +emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO () +emitNativeCode logger config h sdoc = do let ctx = ncgAsmContext config {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc -- dump native code - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm "Asm code" FormatASM sdoc @@ -444,7 +437,6 @@ emitNativeCode logger dflags config h sdoc = do cmmNativeGen :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) => Logger - -> DynFlags -> ModLocation -> NcgImpl statics instr jumpDest -> UniqSupply @@ -461,7 +453,7 @@ cmmNativeGen , LabelMap [UnwindPoint] -- unwinding information for blocks ) -cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count +cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count = do let config = ncgConfig ncgImpl let platform = ncgPlatform config @@ -481,7 +473,7 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count {-# SCC "cmmToCmm" #-} cmmToCmm config fixed_cmm - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM (pprCmmGroup platform [opt_cmm]) @@ -495,11 +487,11 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count (cmmTopCodeGen ncgImpl) fileIds dbgMap opt_cmm cmmCfg - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_native "Native code" FormatASM (vcat $ map (pprNatCmmDecl ncgImpl) native) - maybeDumpCfg logger dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name + maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name -- tag instructions with register liveness information -- also drops dead code. We don't keep the cfg in sync on @@ -512,15 +504,14 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count initUs usGen $ mapM (cmmTopLiveness livenessCfg platform) native - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_liveness "Liveness annotations added" FormatCMM (vcat $ map (pprLiveCmmDecl platform) withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <- - if ( gopt Opt_RegsGraph dflags - || gopt Opt_RegsIterative dflags ) + if ( ncgRegsGraph config || ncgRegsIterative config ) then do -- the regs usable for allocation let (alloc_regs :: UniqFM RegClass (UniqSet RealReg)) @@ -552,12 +543,12 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count -- dump out what happened during register allocation - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_regalloc_stages "Build/spill stages" FormatText (vcat $ map (\(stage, stats) @@ -567,7 +558,7 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count $ zip [0..] regAllocStats) let mPprStats = - if dopt Opt_D_dump_asm_stats dflags + if logHasDumpFlag logger Opt_D_dump_asm_stats then Just regAllocStats else Nothing -- force evaluation of the Maybe to avoid space leak @@ -596,13 +587,13 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count $ liftM unzip3 $ mapM reg_alloc withLiveness - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) let mPprStats = - if dopt Opt_D_dump_asm_stats dflags + if logHasDumpFlag logger Opt_D_dump_asm_stats then Just (catMaybes regAllocStats) else Nothing -- force evaluation of the Maybe to avoid space leak @@ -631,7 +622,7 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count {-# SCC "generateJumpTables" #-} generateJumpTables ncgImpl alloced - when (not $ null nativeCfgWeights) $ dumpIfSet_dyn logger dflags + when (not $ null nativeCfgWeights) $ putDumpFileMaybe logger Opt_D_dump_cfg_weights "CFG Update information" FormatText ( text "stack:" <+> ppr stack_updt_blks $$ @@ -640,20 +631,20 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count ---- shortcut branches let (shorted, postShortCFG) = {-# SCC "shortcutBranches" #-} - shortcutBranches dflags ncgImpl tabled postRegCFG + shortcutBranches config ncgImpl tabled postRegCFG let optimizedCFG :: Maybe CFG optimizedCFG = - optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG + optimizeCFG (ncgCmmStaticPred config) weights cmm <$!> postShortCFG - maybeDumpCfg logger dflags optimizedCFG "CFG Weights - Final" proc_name + maybeDumpCfg logger optimizedCFG "CFG Weights - Final" proc_name --TODO: Partially check validity of the cfg. let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks getBlks _ = [] when ( backendMaintainsCfg platform && - (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do + (ncgAsmLinting config || debugIsOn )) $ do let blocks = concatMap getBlks shorted let labels = setFromList $ fmap blockId blocks :: LabelSet let cfg = fromJust optimizedCFG @@ -687,7 +678,7 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count ncgExpandTop ncgImpl branchOpt --ncgExpandTop ncgImpl sequenced - dumpIfSet_dyn logger dflags + putDumpFileMaybe logger Opt_D_dump_asm_expanded "Synthetic instructions expanded" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) expanded) @@ -699,7 +690,7 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count foldl' addUnwind mapEmpty expanded where addUnwind acc proc = - acc `mapUnion` computeUnwinding dflags ncgImpl proc + acc `mapUnion` computeUnwinding config ncgImpl proc return ( usAlloc , fileIds' @@ -709,13 +700,13 @@ cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count , ppr_raStatsLinear , unwinds ) -maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO () -maybeDumpCfg _logger _dflags Nothing _ _ = return () -maybeDumpCfg logger dflags (Just cfg) msg proc_name +maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO () +maybeDumpCfg _logger Nothing _ _ = return () +maybeDumpCfg logger (Just cfg) msg proc_name | null cfg = return () | otherwise - = dumpIfSet_dyn logger - dflags Opt_D_dump_cfg_weights msg + = putDumpFileMaybe logger + Opt_D_dump_cfg_weights msg FormatText (proc_name <> char ':' $$ pprEdgeWeights cfg) @@ -738,15 +729,16 @@ checkLayout procsUnsequenced procsSequenced = -- | Compute unwinding tables for the blocks of a procedure computeUnwinding :: Instruction instr - => DynFlags -> NcgImpl statics instr jumpDest + => NCGConfig + -> NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -- ^ the native code generated for the procedure -> LabelMap [UnwindPoint] -- ^ unwinding tables for all points of all blocks of the -- procedure -computeUnwinding dflags _ _ - | debugLevel dflags == 0 = mapEmpty -computeUnwinding _ _ (CmmData _ _) = mapEmpty +computeUnwinding config _ _ + | not (ncgComputeUnwinding config) = mapEmpty +computeUnwinding _ _ (CmmData _ _) = mapEmpty computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) = -- In general we would need to push unwinding information down the -- block-level call-graph to ensure that we fully account for all @@ -832,14 +824,15 @@ generateJumpTables ncgImpl xs = concatMap f xs -- Shortcut branches shortcutBranches - :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags + :: forall statics instr jumpDest. (Outputable jumpDest) + => NCGConfig -> NcgImpl statics instr jumpDest -> [NatCmmDecl statics instr] -> Maybe CFG -> ([NatCmmDecl statics instr],Maybe CFG) -shortcutBranches dflags ncgImpl tops weights - | gopt Opt_AsmShortcutting dflags +shortcutBranches config ncgImpl tops weights + | ncgEnableShortcutting config = ( map (apply_mapping ncgImpl mapping) tops' , shortcutWeightMap mappingBid <$!> weights ) | otherwise @@ -1144,56 +1137,3 @@ cmmExprNative referenceKind expr = do other -> return other - --- | Initialize the native code generator configuration from the DynFlags -initNCGConfig :: DynFlags -> Module -> NCGConfig -initNCGConfig dflags this_mod = NCGConfig - { ncgPlatform = targetPlatform dflags - , ncgThisModule = this_mod - , ncgAsmContext = initSDocContext dflags (PprCode AsmStyle) - , ncgProcAlignment = cmmProcAlignment dflags - , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags - , ncgPIC = positionIndependent dflags - , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags - , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags - , ncgSplitSections = gopt Opt_SplitSections dflags - , ncgRegsIterative = gopt Opt_RegsIterative dflags - , ncgAsmLinting = gopt Opt_DoAsmLinting dflags - , ncgCfgWeights = cfgWeights dflags - , ncgCfgBlockLayout = gopt Opt_CfgBlocklayout dflags - , ncgCfgWeightlessLayout = gopt Opt_WeightlessBlocklayout dflags - - -- With -O1 and greater, the cmmSink pass does constant-folding, so - -- we don't need to do it again in the native code generator. - , ncgDoConstantFolding = optLevel dflags < 1 - - , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags - , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags - , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags - , ncgBmiVersion = case platformArch (targetPlatform dflags) of - ArchX86_64 -> bmiVersion dflags - ArchX86 -> bmiVersion dflags - _ -> Nothing - - -- We assume SSE1 and SSE2 operations are available on both - -- x86 and x86_64. Historically we didn't default to SSE2 and - -- SSE1 on x86, which results in defacto nondeterminism for how - -- rounding behaves in the associated x87 floating point instructions - -- because variations in the spill/fpu stack placement of arguments for - -- operations would change the precision and final result of what - -- would otherwise be the same expressions with respect to single or - -- double precision IEEE floating point computations. - , ncgSseVersion = - let v | sseVersion dflags < Just SSE2 = Just SSE2 - | otherwise = sseVersion dflags - in case platformArch (targetPlatform dflags) of - ArchX86_64 -> v - ArchX86 -> v - _ -> Nothing - - , ncgDwarfEnabled = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64 - , ncgDwarfUnwindings = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 - , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1. - , ncgDwarfSourceNotes = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3 - , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags - } diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs index 8acd089757..e981305845 100644 --- a/compiler/GHC/CmmToAsm/Config.hs +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -26,6 +26,7 @@ data NCGConfig = NCGConfig , ncgInlineThresholdMemset :: !Word -- ^ Ditto for `memset` , ncgSplitSections :: !Bool -- ^ Split sections , ncgRegsIterative :: !Bool + , ncgRegsGraph :: !Bool , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass , ncgDoConstantFolding :: !Bool -- ^ Perform CMM constant folding , ncgSseVersion :: Maybe SseVersion -- ^ (x86) SSE instructions @@ -41,6 +42,9 @@ data NCGConfig = NCGConfig , ncgDwarfStripBlockInfo :: !Bool -- ^ Strip out block information from generated Dwarf , ncgExposeInternalSymbols :: !Bool -- ^ Expose symbol table entries for internal symbols , ncgDwarfSourceNotes :: !Bool -- ^ Enable GHC-specific source note DIEs + , ncgCmmStaticPred :: !Bool -- ^ Enable static control-flow prediction + , ncgEnableShortcutting :: !Bool -- ^ Enable shortcutting (don't jump to blocks only containing a jump) + , ncgComputeUnwinding :: !Bool -- ^ Compute block unwinding tables } -- | Return Word size diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index d36be3f6a6..f82dbf258a 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -48,21 +48,21 @@ llvmCodeGen :: Logger -> DynFlags -> Handle -> Stream.Stream IO RawCmmGroup a -> IO a llvmCodeGen logger dflags h cmm_stream - = withTiming logger dflags (text "LLVM CodeGen") (const ()) $ do + = withTiming logger (text "LLVM CodeGen") (const ()) $ do bufh <- newBufHandle h -- Pass header - showPass logger dflags "LLVM CodeGen" + showPass logger "LLVM CodeGen" -- get llvm version, cache for later use mb_ver <- figureLlvmVersion logger dflags -- warn if unsupported forM_ mb_ver $ \ver -> do - debugTraceMsg logger dflags 2 + debugTraceMsg logger 2 (text "Using LLVM version:" <+> text (llvmVersionStr ver)) let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger dflags $ + when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $ "You are using an unsupported version of LLVM!" $$ "Currently only" <+> text (llvmVersionStr supportedLlvmVersionMin) <+> "to" <+> text (llvmVersionStr supportedLlvmVersionMax) <+> "is supported." <+> @@ -70,7 +70,7 @@ llvmCodeGen logger dflags h cmm_stream "We will try though..." let isS390X = platformArch (targetPlatform dflags) == ArchS390X let major_ver = head . llvmVersionList $ ver - when (isS390X && major_ver < 10 && doWarn) $ putMsg logger dflags $ + when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $ "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> "You are using LLVM version: " <> text (llvmVersionStr ver) diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index b3dc6a18c4..60779be4ab 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -425,9 +425,8 @@ getLlvmVer = getEnv envVersion -- | Dumps the document if the corresponding flag has been set by the user dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () dumpIfSetLlvm flag hdr fmt doc = do - dflags <- getDynFlags logger <- getLogger - liftIO $ dumpIfSet_dyn logger dflags flag hdr fmt doc + liftIO $ putDumpFileMaybe logger flag hdr fmt doc -- | Prints the given contents to the output handle renderLlvm :: Outp.SDoc -> LlvmM () diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs index fb052ce333..749cedef2d 100644 --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -13,30 +13,25 @@ module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where import GHC.Prelude -import GHC.Driver.Session ( DynFlags, targetPlatform ) -import GHC.Platform ( platformArch, Arch(..) ) -import GHC.Utils.Error ( withTiming ) -import GHC.Utils.Outputable ( text ) -import GHC.Utils.Logger +import GHC.Platform ( Platform, platformArch, Arch(..) ) import GHC.Utils.Exception (try) import qualified Data.ByteString.Char8 as B import System.IO -- | Read in assembly file and process -llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO () -llvmFixupAsm logger dflags f1 f2 = {-# SCC "llvm_mangler" #-} - withTiming logger dflags (text "LLVM Mangler") id $ - withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do - go r w - hClose r - hClose w - return () +llvmFixupAsm :: Platform -> FilePath -> FilePath -> IO () +llvmFixupAsm platform f1 f2 = {-# SCC "llvm_mangler" #-} + withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do + go r w + hClose r + hClose w + return () where go :: Handle -> Handle -> IO () go r w = do e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString) - let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w + let writeline a = B.hPutStrLn w (rewriteLine platform rewrites a) >> go r w case e_l of Right l -> writeline l Left _ -> return () @@ -45,12 +40,12 @@ llvmFixupAsm logger dflags f1 f2 = {-# SCC "llvm_mangler" #-} rewrites :: [Rewrite] rewrites = [rewriteSymType, rewriteAVX, rewriteCall] -type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString +type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString -- | Rewrite a line of assembly source with the given rewrites, -- taking the first rewrite that applies. -rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString -rewriteLine dflags rewrites l +rewriteLine :: Platform -> [Rewrite] -> B.ByteString -> B.ByteString +rewriteLine platform rewrites l -- We disable .subsections_via_symbols on darwin and ios, as the llvm code -- gen uses prefix data for the info table. This however does not prevent -- llvm from generating .subsections_via_symbols, which in turn with @@ -58,7 +53,7 @@ rewriteLine dflags rewrites l | isSubsectionsViaSymbols l = (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!") | otherwise = - case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of + case firstJust $ map (\rewrite -> rewrite platform rest) rewrites of Nothing -> l Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten] where @@ -97,13 +92,13 @@ rewriteSymType _ l -- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then -- rewrites the instructions in the mangler. rewriteAVX :: Rewrite -rewriteAVX dflags s +rewriteAVX platform s | not isX86_64 = Nothing | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s | otherwise = Nothing where - isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64 + isX86_64 = platformArch platform == ArchX86_64 isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") isVmovap = B.isPrefixOf (B.pack "vmovap") @@ -111,13 +106,13 @@ rewriteAVX dflags s -- functions on riscv64. The replacement will load the address from the -- GOT, which is resolved to point to the real address of the function. rewriteCall :: Rewrite -rewriteCall dflags l +rewriteCall platform l | not isRISCV64 = Nothing | isCall l = Just $ replaceCall "call" "jalr" "ra" l | isTail l = Just $ replaceCall "tail" "jr" "t1" l | otherwise = Nothing where - isRISCV64 = platformArch (targetPlatform dflags) == ArchRISCV64 + isRISCV64 = platformArch platform == ArchRISCV64 isCall = B.isPrefixOf (B.pack "call\t") isTail = B.isPrefixOf (B.pack "tail\t") diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index ad3bad1d7d..fdef694cec 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -20,8 +20,7 @@ module GHC.Core.Lint ( -- ** Debug output endPass, endPassIO, - displayLintResults, dumpPassResult, - dumpIfSet, + displayLintResults, dumpPassResult ) where import GHC.Prelude @@ -67,8 +66,7 @@ import GHC.Core.Unify import GHC.Types.Basic import GHC.Utils.Error import qualified GHC.Utils.Error as Err -import GHC.Utils.Logger (Logger, putLogMsg, putDumpMsg, DumpFormat (..), getLogger) -import qualified GHC.Utils.Logger as Logger +import GHC.Utils.Logger import GHC.Data.List.SetOps import GHC.Builtin.Names import GHC.Utils.Outputable as Outputable @@ -290,44 +288,37 @@ endPassIO :: HscEnv -> PrintUnqualified -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too endPassIO hsc_env print_unqual pass binds rules - = do { dumpPassResult logger dflags print_unqual mb_flag - (ppr pass) (pprPassDetails pass) binds rules + = do { dumpPassResult logger print_unqual mb_flag + (showSDoc dflags (ppr pass)) (pprPassDetails pass) binds rules ; lintPassResult hsc_env pass binds } where logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env mb_flag = case coreDumpFlag pass of - Just flag | dopt flag dflags -> Just flag - | dopt Opt_D_verbose_core2core dflags -> Just flag + Just flag | logHasDumpFlag logger flag -> Just flag + | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag _ -> Nothing -dumpIfSet :: Logger -> DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () -dumpIfSet logger dflags dump_me pass extra_info doc - = Logger.dumpIfSet logger dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc - dumpPassResult :: Logger - -> DynFlags -> PrintUnqualified -> Maybe DumpFlag -- Just df => show details in a file whose -- name is specified by df - -> SDoc -- Header + -> String -- Header -> SDoc -- Extra info to appear after header -> CoreProgram -> [CoreRule] -> IO () -dumpPassResult logger dflags unqual mb_flag hdr extra_info binds rules +dumpPassResult logger unqual mb_flag hdr extra_info binds rules = do { forM_ mb_flag $ \flag -> do - let sty = mkDumpStyle unqual - putDumpMsg logger dflags sty flag - (showSDoc dflags hdr) FormatCore dump_doc + logDumpFile logger (mkDumpStyle unqual) flag hdr FormatCore dump_doc -- Report result size -- This has the side effect of forcing the intermediate to be evaluated -- if it's not already forced by a -ddump flag. - ; Err.debugTraceMsg logger dflags 2 size_doc + ; Err.debugTraceMsg logger 2 size_doc } where - size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] dump_doc = vcat [ nest 2 extra_info , size_doc @@ -379,37 +370,36 @@ lintPassResult hsc_env pass binds = return () | otherwise = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope $ hsc_IC hsc_env) binds - ; Err.showPass logger dflags ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults logger dflags (showLintWarnings pass) (ppr pass) + ; Err.showPass logger ("Core Linted result of " ++ showPpr dflags pass) + ; displayLintResults logger (showLintWarnings pass) (ppr pass) (pprCoreBindings binds) warns_and_errs } where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env displayLintResults :: Logger - -> DynFlags -> Bool -- ^ If 'True', display linter warnings. -- If 'False', ignore linter warnings. -> SDoc -- ^ The source of the linted program -> SDoc -- ^ The linted program, pretty-printed -> WarnsAndErrs -> IO () -displayLintResults logger dflags display_warnings pp_what pp_pgm (warns, errs) +displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag errs) - = do { putLogMsg logger dflags Err.MCDump noSrcSpan + = do { logMsg logger Err.MCDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs , text "*** Offending Program ***" , pp_pgm , text "*** End of Offense ***" ]) - ; Err.ghcExit logger dflags 1 } + ; Err.ghcExit logger 1 } | not (isEmptyBag warns) - , not (hasNoDebugOutput dflags) + , log_enable_debug (logFlags logger) , display_warnings -- If the Core linter encounters an error, output to stderr instead of -- stdout (#13342) - = putLogMsg logger dflags Err.MCInfo noSrcSpan + = logMsg logger Err.MCInfo noSrcSpan $ withPprStyle defaultDumpStyle (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) @@ -432,7 +422,7 @@ lintInteractiveExpr what hsc_env expr | not (gopt Opt_DoCoreLinting dflags) = return () | Just err <- lintExpr dflags (interactiveInScope $ hsc_IC hsc_env) expr - = displayLintResults logger dflags False what (pprCoreExpr expr) (emptyBag, err) + = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err) | otherwise = return () where @@ -2357,7 +2347,7 @@ lintAxioms :: Logger -> [CoAxiom Branched] -> IO () lintAxioms logger dflags what axioms = - displayLintResults logger dflags True what (vcat $ map pprCoAxiom axioms) $ + displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $ initL dflags (defaultLintFlags dflags) [] $ do { mapM_ lint_axiom axioms ; let axiom_groups = groupWith coAxiomTyCon axioms @@ -3306,15 +3296,15 @@ lintAnnots pname pass guts = do dflags <- getDynFlags logger <- getLogger when (gopt Opt_DoAnnotationLinting dflags) $ - liftIO $ Err.showPass logger dflags "Annotation linting - first run" + liftIO $ Err.showPass logger "Annotation linting - first run" nguts <- pass guts -- If appropriate re-run it without debug annotations to make sure -- that they made no difference. when (gopt Opt_DoAnnotationLinting dflags) $ do - liftIO $ Err.showPass logger dflags "Annotation linting - second run" + liftIO $ Err.showPass logger "Annotation linting - second run" nguts' <- withoutAnnots pass guts -- Finally compare the resulting bindings - liftIO $ Err.showPass logger dflags "Annotation linting - comparison" + liftIO $ Err.showPass logger "Annotation linting - comparison" let binds = flattenBinds $ mg_binds nguts binds' = flattenBinds $ mg_binds nguts' (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' @@ -3333,7 +3323,7 @@ withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts withoutAnnots pass guts = do -- Remove debug flag from environment. dflags <- getDynFlags - let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} } + let removeFlag env = hscSetFlags (dflags { debugLevel = 0}) env withoutFlag corem = -- TODO: supply tag here as well ? liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index 53b5983758..254b215537 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -13,7 +13,6 @@ import GHC.Prelude import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Driver.Session ( DynFlags ) import GHC.Types.Basic import GHC.Core @@ -434,8 +433,8 @@ choice, and hence Call Arity sets the call arity for join points as well. -- Main entry point -callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram -callArityAnalProgram _dflags binds = binds' +callArityAnalProgram :: CoreProgram -> CoreProgram +callArityAnalProgram binds = binds' where (_, binds') = callArityTopLvl [] emptyVarSet binds diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index a697dd65d0..91f6abef0d 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -30,7 +30,7 @@ import GHC.Core.Type import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe ) import GHC.Utils.Misc import GHC.Utils.Panic.Plain -import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Utils.Logger ( Logger, putDumpFileMaybe, DumpFormat (..) ) import GHC.Data.Graph.UnVar -- for UnVarSet import GHC.Data.Maybe ( isJust ) @@ -108,11 +108,11 @@ So currently we have -- * Analysing programs -- -cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -cprAnalProgram logger dflags fam_envs binds = do +cprAnalProgram :: Logger -> FamInstEnvs -> CoreProgram -> IO CoreProgram +cprAnalProgram logger fam_envs binds = do let env = emptyAnalEnv fam_envs let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds - dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ + putDumpFileMaybe logger Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ dumpIdInfoOfProgram (ppr . cprSigInfo) binds_plus_cpr -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_cpr `seq` return binds_plus_cpr diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index 6826e9da8f..6e4b724310 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -21,13 +21,10 @@ module GHC.Core.Opt.FloatIn ( floatInwards ) where import GHC.Prelude import GHC.Platform -import GHC.Driver.Session - import GHC.Core import GHC.Core.Make hiding ( wrapFloats ) import GHC.Core.Utils import GHC.Core.FVs -import GHC.Core.Opt.Monad ( CoreM ) import GHC.Core.Type import GHC.Types.Basic ( RecFlag(..), isRec ) @@ -36,8 +33,6 @@ import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Var.Set -import GHC.Unit.Module.ModGuts - import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -47,11 +42,8 @@ Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level. -} -floatInwards :: ModGuts -> CoreM ModGuts -floatInwards pgm@(ModGuts { mg_binds = binds }) - = do { dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; return (pgm { mg_binds = map (fi_top_bind platform) binds }) } +floatInwards :: Platform -> CoreProgram -> CoreProgram +floatInwards platform binds = map (fi_top_bind platform) binds where fi_top_bind platform (NonRec binder rhs) = NonRec binder (fiExpr platform [] (freeVars rhs)) diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index 9f579a0a2e..fbed53fbf3 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -19,7 +19,7 @@ import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Driver.Session -import GHC.Utils.Logger ( dumpIfSet_dyn, DumpFormat (..), Logger ) +import GHC.Utils.Logger import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish @@ -164,23 +164,22 @@ Without floating, we're stuck with three loops instead of one. floatOutwards :: Logger -> FloatOutSwitches - -> DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram -floatOutwards logger float_sws dflags us pgm +floatOutwards logger float_sws us pgm = do { let { annotated_w_levels = setLevels float_sws pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) } ; - dumpIfSet_dyn logger dflags Opt_D_verbose_core2core "Levels added:" + putDumpFileMaybe logger Opt_D_verbose_core2core "Levels added:" FormatCore (vcat (map ppr annotated_w_levels)); let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; - dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats "FloatOut stats:" + putDumpFileMaybe logger Opt_D_dump_simpl_stats "FloatOut stats:" FormatText (hcat [ int tlets, text " Lets floated to top level; ", int ntlets, text " Lets floated elsewhere; from ", diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index e8f1fb11e3..c0102961b5 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -45,7 +45,6 @@ module GHC.Core.Opt.Monad ( putMsg, putMsgS, errorMsg, errorMsgS, msg, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, - dumpIfSet_dyn ) where import GHC.Prelude hiding ( read ) @@ -66,7 +65,7 @@ import GHC.Types.Error import GHC.Utils.Error ( errorDiagnostic ) import GHC.Utils.Outputable as Outputable -import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger ) +import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Data.FastString @@ -182,7 +181,6 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad -- - target platform (for `exprIsDupable` and `mkDupableAlt`) -- - Opt_DictsCheap and Opt_PedanticBottoms general flags -- - rules options (initRuleOpts) - -- - verbose_core2core, dump_inlinings, dump_rule_rewrites/firings -- - inlineCheck } @@ -794,7 +792,6 @@ we aren't using annotations heavily. msg :: MessageClass -> SDoc -> CoreM () msg msg_class doc = do - dflags <- getDynFlags logger <- getLogger loc <- getSrcSpanM unqual <- getPrintUnqualified @@ -805,7 +802,7 @@ msg msg_class doc = do err_sty = mkErrStyle unqual user_sty = mkUserStyle unqual AllTheWay dump_sty = mkDumpStyle unqual - liftIO $ putLogMsg logger dflags msg_class loc (withPprStyle sty doc) + liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -838,13 +835,3 @@ debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () debugTraceMsg = msg MCDump - --- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher -dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM () -dumpIfSet_dyn flag str fmt doc = do - dflags <- getDynFlags - logger <- getLogger - unqual <- getPrintUnqualified - when (dopt flag dflags) $ liftIO $ do - let sty = mkDumpStyle unqual - putDumpMsg logger dflags sty flag str fmt doc diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 90b5968a2f..6e2f3aceee 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -47,7 +47,6 @@ import GHC.Core.Opt.CallerCC ( addCallerCostCentres ) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv -import qualified GHC.Utils.Error as Err import GHC.Utils.Error ( withTiming ) import GHC.Utils.Logger as Logger import GHC.Utils.Outputable @@ -61,7 +60,6 @@ import GHC.Unit.Module.Deps import GHC.Runtime.Context -import GHC.Types.SrcLoc import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic @@ -69,7 +67,6 @@ import GHC.Types.Demand ( zapDmdEnvSig ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish -import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Types.Unique.FM import GHC.Types.Name.Ppr @@ -100,7 +97,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod builtin_passes ; runCorePasses all_passes guts } - ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats "Grand total simplifier statistics" FormatText (pprSimplCount stats) @@ -465,9 +462,8 @@ runCorePasses passes guts do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts pass = do - dflags <- getDynFlags logger <- getLogger - withTiming logger dflags (ppr pass <+> brackets (ppr mod)) + withTiming logger (ppr pass <+> brackets (ppr mod)) (const ()) $ do guts' <- lintAnnots (ppr pass) (doCorePass pass) guts endPass pass (mg_binds guts') (mg_rules guts') @@ -477,40 +473,48 @@ runCorePasses passes guts doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass guts = do - logger <- getLogger + logger <- getLogger + dflags <- getDynFlags + us <- getUniqueSupplyM + p_fam_env <- getPackageFamInstEnv + let platform = targetPlatform dflags + let fam_envs = (p_fam_env, mg_fam_inst_env guts) + let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } + let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } + case pass of CoreDoSimplify {} -> {-# SCC "Simplify" #-} simplifyPgm pass guts CoreCSE -> {-# SCC "CommonSubExpr" #-} - doPass cseProgram guts + updateBinds cseProgram CoreLiberateCase -> {-# SCC "LiberateCase" #-} - doPassD liberateCase guts + updateBinds (liberateCase dflags) CoreDoFloatInwards -> {-# SCC "FloatInwards" #-} - floatInwards guts + updateBinds (floatInwards platform) CoreDoFloatOutwards f -> {-# SCC "FloatOutwards" #-} - doPassDUM (floatOutwards logger f) guts + updateBindsM (liftIO . floatOutwards logger f us) CoreDoStaticArgs -> {-# SCC "StaticArgs" #-} - doPassU doStaticArgs guts + updateBinds (doStaticArgs us) CoreDoCallArity -> {-# SCC "CallArity" #-} - doPassD callArityAnalProgram guts + updateBinds callArityAnalProgram CoreDoExitify -> {-# SCC "Exitify" #-} - doPass exitifyProgram guts + updateBinds exitifyProgram CoreDoDemand -> {-# SCC "DmdAnal" #-} - doPassDFRM (dmdAnal logger) guts + updateBindsM (liftIO . dmdAnal logger dflags fam_envs (mg_rules guts)) CoreDoCpr -> {-# SCC "CprAnal" #-} - doPassDFM (cprAnalProgram logger) guts + updateBindsM (liftIO . cprAnalProgram logger fam_envs) CoreDoWorkerWrapper -> {-# SCC "WorkWrap" #-} - doPassDFU wwTopBinds guts + updateBinds (wwTopBinds dflags fam_envs us) CoreDoSpecialising -> {-# SCC "Specialise" #-} specProgram guts @@ -521,7 +525,7 @@ doCorePass pass guts = do CoreAddCallerCcs -> {-# SCC "AddCallerCcs" #-} addCallerCostCentres guts - CoreDoPrintCore -> observe (printCore logger) guts + CoreDoPrintCore -> liftIO $ printCore logger (mg_binds guts) >> return guts CoreDoRuleCheck phase pat -> ruleCheckPass phase pat guts CoreDoNothing -> return guts @@ -543,84 +547,26 @@ doCorePass pass guts = do ************************************************************************ -} -printCore :: Logger -> DynFlags -> CoreProgram -> IO () -printCore logger dflags binds - = Logger.dumpIfSet logger dflags True "Print Core" (pprCoreBindings binds) +printCore :: Logger -> CoreProgram -> IO () +printCore logger binds + = Logger.logDumpMsg logger "Print Core" (pprCoreBindings binds) ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheckPass current_phase pat guts = do dflags <- getDynFlags logger <- getLogger - withTiming logger dflags (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) + withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) (const ()) $ do rb <- getRuleBase vis_orphs <- getVisibleOrphanMods let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn ++ (mg_rules guts) let ropts = initRuleOpts dflags - liftIO $ putLogMsg logger dflags Err.MCDump noSrcSpan - $ withPprStyle defaultDumpStyle + liftIO $ logDumpMsg logger "Rule check" (ruleCheckProgram ropts current_phase pat rule_fn (mg_binds guts)) return guts -doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDUM do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - us <- getUniqueSupplyM - liftIO $ do_pass dflags us binds - -doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) - -doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) - -doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) - -doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassU do_pass = doPassDU (const do_pass) - -doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFM do_pass guts = do - dflags <- getDynFlags - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPassM (liftIO . do_pass dflags fam_envs) guts - -doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFRM do_pass guts = do - dflags <- getDynFlags - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPassM (liftIO . do_pass dflags fam_envs (mg_rules guts)) guts - -doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPassDFU do_pass guts = do - dflags <- getDynFlags - us <- getUniqueSupplyM - p_fam_env <- getPackageFamInstEnv - let fam_envs = (p_fam_env, mg_fam_inst_env guts) - doPass (do_pass dflags fam_envs us) guts - --- Most passes return no stats and don't change rules: these combinators --- let us lift them to the full blown ModGuts+CoreM world -doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts -doPassM bind_f guts = do - binds' <- bind_f (mg_binds guts) - return (guts { mg_binds = binds' }) - -doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts -doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } - --- Observer passes just peek; don't modify the bindings at all -observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts -observe do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - _ <- liftIO $ do_pass dflags binds - return binds - {- ************************************************************************ * * @@ -635,7 +581,7 @@ simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt simplifyExpr hsc_env expr - = withTiming logger dflags (text "Simplify [expr]") (const ()) $ + = withTiming logger (text "Simplify [expr]") (const ()) $ do { eps <- hscEPS hsc_env ; ; let rule_env = mkRuleEnv (eps_rule_base eps) [] fi_env = ( eps_fam_inst_env eps @@ -648,10 +594,10 @@ simplifyExpr hsc_env expr ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $ simplExprGently simpl_env expr - ; Logger.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics" (pprSimplCount counts) + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats + "Simplifier statistics" FormatText (pprSimplCount counts) - ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl "Simplified expression" + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" FormatCore (pprCoreExpr expr') @@ -714,8 +660,9 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) = do { (termination_msg, it_count, counts_out, guts') <- do_iteration 1 [] binds rules - ; Logger.dumpIfSet logger dflags (dopt Opt_D_verbose_core2core dflags && - dopt Opt_D_dump_simpl_stats dflags) + ; when (logHasDumpFlag logger Opt_D_verbose_core2core + && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ + logDumpMsg logger "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", @@ -766,7 +713,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) occurAnalysePgm this_mod active_unf active_rule rules binds } ; - Logger.dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis" + Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings tagged_binds); @@ -814,7 +761,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - dump_end_iteration logger dflags print_unqual iteration_no counts1 binds2 rules1 ; + dump_end_iteration logger print_unqual iteration_no counts1 binds2 rules1 ; lintPassResult hsc_env pass binds2 ; -- Loop @@ -832,19 +779,19 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO" ------------------- -dump_end_iteration :: Logger -> DynFlags -> PrintUnqualified -> Int +dump_end_iteration :: Logger -> PrintUnqualified -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration logger dflags print_unqual iteration_no counts binds rules - = dumpPassResult logger dflags print_unqual mb_flag hdr pp_counts binds rules +dump_end_iteration logger print_unqual iteration_no counts binds rules + = dumpPassResult logger print_unqual mb_flag hdr pp_counts binds rules where - mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations - | otherwise = Nothing + mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing -- Show details if Opt_D_dump_simpl_iterations is on - hdr = text "Simplifier iteration=" <> int iteration_no - pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr + hdr = "Simplifier iteration=" ++ show iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr , pprSimplCount counts - , text "---- End of simplifier counts for" <+> hdr ] + , text "---- End of simplifier counts for" <+> text hdr ] {- ************************************************************************ @@ -1111,7 +1058,7 @@ dmdAnal logger dflags fam_envs rules binds = do { dmd_strict_dicts = gopt Opt_DictsStrict dflags } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds - Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ + Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $ dumpIdInfoOfProgram (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_dmds `seq` return binds_plus_dmds diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 12b277beb2..19705f5541 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -302,16 +302,15 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env where - dflags = seDynFlags env logger = seLogger env -- trace_bind emits a trace for each top-level binding, which -- helps to locate the tracing for inlining and rule firing trace_bind what thing_inside - | not (dopt Opt_D_verbose_core2core dflags) + | not (logHasDumpFlag logger Opt_D_verbose_core2core) = thing_inside | otherwise - = putTraceMsg logger dflags ("SimplBind " ++ what) + = logTraceMsg logger ("SimplBind " ++ what) (ppr old_bndr) thing_inside -------------------------- @@ -1948,7 +1947,7 @@ simplIdF env var cont completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) completeCall env var cont - | Just expr <- callSiteInline logger dflags case_depth var active_unf + | Just expr <- callSiteInline logger uf_opts case_depth var active_unf lone_variable arg_infos interesting_cont -- Inline the variable's RHS = do { checkedTick (UnfoldingDone var) @@ -1965,7 +1964,7 @@ completeCall env var cont ; rebuildCall env info cont } where - dflags = seDynFlags env + uf_opts = seUnfoldingOpts env case_depth = seCaseDepth env logger = seLogger env (lone_variable, arg_infos, call_cont) = contArgs cont @@ -1974,14 +1973,13 @@ completeCall env var cont active_unf = activeUnfolding (getMode env) var log_inlining doc - = liftIO $ putDumpMsg logger dflags - (mkDumpStyle alwaysQualify) + = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) Opt_D_dump_inlinings "" FormatText doc dump_inline unfolding cont - | not (dopt Opt_D_dump_inlinings dflags) = return () - | not (dopt Opt_D_verbose_core2core dflags) + | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () + | not (logHasDumpFlag logger Opt_D_verbose_core2core) = when (isExternalName (idName var)) $ log_inlining $ sep [text "Inlining done:", nest 4 (ppr var)] @@ -2248,8 +2246,8 @@ tryRules env rules fn args call_cont (ruleModule rule)) dump rule rule_rhs - | dopt Opt_D_dump_rule_rewrites dflags - = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat [ text "Rule:" <+> ftext (ruleName rule) , text "Module:" <+> printRuleModule rule , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) @@ -2257,8 +2255,8 @@ tryRules env rules fn args call_cont (sep $ map ppr $ drop (ruleArity rule) args) , text "Cont: " <+> ppr call_cont ] - | dopt Opt_D_dump_rule_firings dflags - = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $ + | logHasDumpFlag logger Opt_D_dump_rule_firings + = log_rule Opt_D_dump_rule_firings "Rule fired:" $ ftext (ruleName rule) <+> printRuleModule rule @@ -2266,22 +2264,20 @@ tryRules env rules fn args call_cont = return () nodump - | dopt Opt_D_dump_rule_rewrites dflags + | logHasDumpFlag logger Opt_D_dump_rule_rewrites = liftIO $ - touchDumpFile logger dflags Opt_D_dump_rule_rewrites + touchDumpFile logger Opt_D_dump_rule_rewrites - | dopt Opt_D_dump_rule_firings dflags + | logHasDumpFlag logger Opt_D_dump_rule_firings = liftIO $ - touchDumpFile logger dflags Opt_D_dump_rule_firings + touchDumpFile logger Opt_D_dump_rule_firings | otherwise = return () - log_rule dflags flag hdr details - = liftIO $ do - let sty = mkDumpStyle alwaysQualify - putDumpMsg logger dflags sty flag "" FormatText $ - sep [text hdr, nest 4 details] + log_rule flag hdr details + = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText + $ sep [text hdr, nest 4 details] trySeqRules :: SimplEnv -> OutExpr -> InExpr -- Scrutinee and RHS diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index 1705cd878f..c730a3e981 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -169,9 +169,8 @@ thenSmpl_ m k traceSmpl :: String -> SDoc -> SimplM () traceSmpl herald doc - = do dflags <- getDynFlags - logger <- getLogger - liftIO $ Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_trace "Simpl Trace" + = do logger <- getLogger + liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace" FormatText (hang (text herald) 2 doc) {-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities] diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 916eb79a45..bd02bd6fc1 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -26,7 +26,8 @@ module GHC.Core.Unfold ( UnfoldingOpts (..), defaultUnfoldingOpts, updateCreationThreshold, updateUseThreshold, updateFunAppDiscount, updateDictDiscount, - updateVeryAggressive, updateCaseScaling, updateCaseThreshold, + updateVeryAggressive, updateCaseScaling, + updateCaseThreshold, updateReportPrefix, ArgSummary(..), @@ -39,8 +40,9 @@ module GHC.Core.Unfold ( import GHC.Prelude -import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Flags + import GHC.Core import GHC.Core.Utils import GHC.Types.Id @@ -82,11 +84,14 @@ data UnfoldingOpts = UnfoldingOpts , unfoldingVeryAggressive :: !Bool -- ^ Force inlining in many more cases - -- Don't consider depth up to x , unfoldingCaseThreshold :: !Int + -- ^ Don't consider depth up to x - -- Penalize depth with 1/x , unfoldingCaseScaling :: !Int + -- ^ Penalize depth with 1/x + + , unfoldingReportPrefix :: !(Maybe String) + -- ^ Only report inlining decisions for names with this prefix } defaultUnfoldingOpts :: UnfoldingOpts @@ -118,6 +123,9 @@ defaultUnfoldingOpts = UnfoldingOpts -- Penalize depth with (size*depth)/scaling , unfoldingCaseScaling = 30 + + -- Don't filter inlining decision reports + , unfoldingReportPrefix = Nothing } -- Helpers for "GHC.Driver.Session" @@ -144,6 +152,9 @@ updateCaseThreshold n opts = opts { unfoldingCaseThreshold = n } updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts updateCaseScaling n opts = opts { unfoldingCaseScaling = n } +updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts +updateReportPrefix n opts = opts { unfoldingReportPrefix = n } + {- Note [Occurrence analysis of unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1057,16 +1068,6 @@ them inlining is to give them a NOINLINE pragma, which we do in StrictAnal.addStrictnessInfoToTopId -} -callSiteInline :: Logger - -> DynFlags - -> Int -- Case depth - -> Id -- The Id - -> Bool -- True <=> unfolding is active - -> Bool -- True if there are no arguments at all (incl type args) - -> [ArgSummary] -- One for each value arg; True if it is interesting - -> CallCtxt -- True <=> continuation is interesting - -> Maybe CoreExpr -- Unfolding, if any - data ArgSummary = TrivArg -- Nothing interesting | NonTrivArg -- Arg has structure | ValueArg -- Arg is a con-app or PAP @@ -1102,7 +1103,16 @@ instance Outputable CallCtxt where ppr DiscArgCtxt = text "DiscArgCtxt" ppr RuleArgCtxt = text "RuleArgCtxt" -callSiteInline logger dflags !case_depth id active_unfolding lone_variable arg_infos cont_info +callSiteInline :: Logger + -> UnfoldingOpts + -> Int -- Case depth + -> Id -- The Id + -> Bool -- True <=> unfolding is active + -> Bool -- True if there are no arguments at all (incl type args) + -> [ArgSummary] -- One for each value arg; True if it is interesting + -> CallCtxt -- True <=> continuation is interesting + -> Maybe CoreExpr -- Unfolding, if any +callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_infos cont_info = case idUnfolding id of -- idUnfolding checks for loop-breakers, returning NoUnfolding -- Things with an INLINE pragma may have an unfolding *and* @@ -1110,28 +1120,28 @@ callSiteInline logger dflags !case_depth id active_unfolding lone_variable arg_i CoreUnfolding { uf_tmpl = unf_template , uf_is_work_free = is_wf , uf_guidance = guidance, uf_expandable = is_exp } - | active_unfolding -> tryUnfolding logger dflags case_depth id lone_variable + | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable arg_infos cont_info unf_template is_wf is_exp guidance - | otherwise -> traceInline logger dflags id "Inactive unfolding:" (ppr id) Nothing + | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing NoUnfolding -> Nothing BootUnfolding -> Nothing OtherCon {} -> Nothing DFunUnfolding {} -> Nothing -- Never unfold a DFun -- | Report the inlining of an identifier's RHS to the user, if requested. -traceInline :: Logger -> DynFlags -> Id -> String -> SDoc -> a -> a -traceInline logger dflags inline_id str doc result +traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a +traceInline logger opts inline_id str doc result -- We take care to ensure that doc is used in only one branch, ensuring that -- the simplifier can push its allocation into the branch. See Note [INLINE -- conditional tracing utilities]. - | enable = putTraceMsg logger dflags str doc result + | enable = logTraceMsg logger str doc result | otherwise = result where enable - | dopt Opt_D_dump_verbose_inlinings dflags + | logHasDumpFlag logger Opt_D_dump_verbose_inlinings = True - | Just prefix <- inlineCheck dflags + | Just prefix <- unfoldingReportPrefix opts = prefix `isPrefixOf` occNameString (getOccName inline_id) | otherwise = False @@ -1233,48 +1243,47 @@ needed on a per-module basis. -} -tryUnfolding :: Logger -> DynFlags -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt +tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance -> Maybe CoreExpr -tryUnfolding logger dflags !case_depth id lone_variable +tryUnfolding logger opts !case_depth id lone_variable arg_infos cont_info unf_template is_wf is_exp guidance = case guidance of - UnfNever -> traceInline logger dflags id str (text "UnfNever") Nothing + UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive uf_opts) + | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts) -- See Note [INLINE for small functions (3)] - -> traceInline logger dflags id str (mk_doc some_benefit empty True) (Just unf_template) + -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template) | otherwise - -> traceInline logger dflags id str (mk_doc some_benefit empty False) Nothing + -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing where some_benefit = calc_some_benefit uf_arity enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } - | unfoldingVeryAggressive uf_opts - -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + | unfoldingVeryAggressive opts + -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template) | is_wf && some_benefit && small_enough - -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template) | otherwise - -> traceInline logger dflags id str (mk_doc some_benefit extra_doc False) Nothing + -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing where some_benefit = calc_some_benefit (length arg_discounts) extra_doc = vcat [ text "case depth =" <+> int case_depth , text "depth based penalty =" <+> int depth_penalty , text "discounted size =" <+> int adjusted_size ] -- See Note [Avoid inlining into deeply nested cases] - depth_treshold = unfoldingCaseThreshold uf_opts - depth_scaling = unfoldingCaseScaling uf_opts + depth_treshold = unfoldingCaseThreshold opts + depth_scaling = unfoldingCaseScaling opts depth_penalty | case_depth <= depth_treshold = 0 | otherwise = (size * (case_depth - depth_treshold)) `div` depth_scaling adjusted_size = size + depth_penalty - discount - small_enough = adjusted_size <= unfoldingUseThreshold uf_opts + small_enough = adjusted_size <= unfoldingUseThreshold opts discount = computeDiscount arg_discounts res_discount arg_infos cont_info where - uf_opts = unfoldingOpts dflags mk_doc some_benefit extra_doc yes_or_no = vcat [ text "arg infos" <+> ppr arg_infos , text "interesting continuation" <+> ppr cont_info @@ -1285,7 +1294,7 @@ tryUnfolding logger dflags !case_depth id lone_variable , extra_doc , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] - ctx = initSDocContext dflags defaultDumpStyle + ctx = log_default_dump_context (logFlags logger) str = "Considering inlining: " ++ showSDocDump ctx (ppr id) n_val_args = length arg_infos diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 4fff314839..6c86ef990a 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -243,7 +243,7 @@ type CpeRhs = CoreExpr -- Non-terminal 'rhs' corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] -> IO (CoreProgram, S.Set CostCentre) corePrepPgm hsc_env this_mod mod_loc binds data_tycons = - withTiming logger dflags + withTiming logger (text "CorePrep"<+>brackets (ppr this_mod)) (\(a,b) -> a `seqList` b `seq` ()) $ do us <- mkSplitUniqSupply 's' @@ -272,13 +272,12 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons = corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr hsc_env expr = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - withTiming logger dflags (text "CorePrep [expr]") (\e -> e `seq` ()) $ do + withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do us <- mkSplitUniqSupply 's' initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn logger dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) + putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) return new_expr corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 1d5b567359..d9723c0f1b 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -21,7 +21,7 @@ import GHC.Prelude -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr @@ -97,7 +97,7 @@ doBackpack [src_filename] = do let dflags1 = dflags0 src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts - modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) + modifySession (hscSetFlags dflags) -- Cribbed from: preprocessFile / GHC.Driver.Pipeline liftIO $ checkProcessArgsResult unhandled_flags liftIO $ handleFlagWarnings logger dflags warns @@ -178,9 +178,7 @@ withBkpSession cid insts deps session_type do_this = do , not (null insts) = sub_comp (key_base p) </> uid_str | otherwise = sub_comp (key_base p) - mk_temp_env hsc_env = hsc_env - { hsc_dflags = mk_temp_dflags (hsc_units hsc_env) (hsc_dflags hsc_env) - } + mk_temp_env hsc_env = hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env mk_temp_dflags unit_state dflags = dflags { backend = case session_type of TcSession -> NoBackend @@ -443,10 +441,7 @@ addUnit u = do , ue_units = unit_state , ue_unit_dbs = Just dbs } - setSession $ hsc_env - { hsc_dflags = dflags - , hsc_unit_env = unit_env - } + setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do @@ -544,10 +539,10 @@ initBkpM file bkp m = -- | Print a compilation progress message, but with indentation according -- to @level@ (for nested compilation). -backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO () -backpackProgressMsg level logger dflags msg = - compilationProgressMsg logger dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr - <> msg +backpackProgressMsg :: Int -> Logger -> SDoc -> IO () +backpackProgressMsg level logger msg = + compilationProgressMsg logger $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr + <> msg -- | Creates a 'Messager' for Backpack compilation; this is basically -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which @@ -560,7 +555,7 @@ mkBackpackMsg = do logger = hsc_logger hsc_env state = hsc_units hsc_env showMsg msg reason = - backpackProgressMsg level logger dflags $ pprWithUnitState state $ + backpackProgressMsg level logger $ pprWithUnitState state $ showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node <> reason @@ -593,21 +588,19 @@ backpackStyle = -- | Message when we initially process a Backpack unit. msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do - dflags <- getDynFlags logger <- getLogger level <- getBkpLevel - liftIO . backpackProgressMsg level logger dflags + liftIO . backpackProgressMsg level logger $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn -- | Message when we instantiate a Backpack unit. msgUnitId :: Unit -> BkpM () msgUnitId pk = do - dflags <- getDynFlags logger <- getLogger hsc_env <- getSession level <- getBkpLevel let state = hsc_units hsc_env - liftIO . backpackProgressMsg level logger dflags + liftIO . backpackProgressMsg level logger $ pprWithUnitState state $ text "Instantiating " <> withPprStyle backpackStyle (ppr pk) @@ -615,12 +608,11 @@ msgUnitId pk = do -- | Message when we include a Backpack unit. msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do - dflags <- getDynFlags logger <- getLogger hsc_env <- getSession level <- getBkpLevel let state = hsc_units hsc_env - liftIO . backpackProgressMsg level logger dflags + liftIO . backpackProgressMsg level logger $ pprWithUnitState state $ showModuleIndex (i, n) <> text "Including " <> withPprStyle backpackStyle (ppr uid) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 4f80b6feda..7c9c08e4c1 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -27,6 +27,7 @@ import GHC.Cmm ( RawCmmGroup ) import GHC.Cmm.CLabel import GHC.Driver.Session +import GHC.Driver.Config.CmmToAsm (initNCGConfig) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -92,16 +93,14 @@ codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStu else cmm_stream do_lint cmm = withTimingSilent logger - dflags (text "CmmLint"<+>brackets (ppr this_mod)) (const ()) $ do { case cmmLint (targetPlatform dflags) cmm of - Just err -> do { putLogMsg logger - dflags + Just err -> do { logMsg logger MCDump noSrcSpan $ withPprStyle defaultDumpStyle err - ; ghcExit logger dflags 1 + ; ghcExit logger 1 } Nothing -> return () ; return cmm @@ -137,7 +136,7 @@ outputC :: Logger -> [UnitId] -> IO a outputC logger dflags filenm cmm_stream packages = - withTiming logger dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do + withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do let pkg_names = map unitIdString packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") @@ -145,7 +144,7 @@ outputC logger dflags filenm cmm_stream packages = let platform = targetPlatform dflags writeC cmm = do let doc = cmmToC platform cmm - dumpIfSet_dyn logger dflags Opt_D_dump_c_backend + putDumpFileMaybe logger Opt_D_dump_c_backend "C backend output" FormatC doc @@ -169,10 +168,11 @@ outputAsm :: Logger -> IO a outputAsm logger dflags this_mod location filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' - debugTraceMsg logger dflags 4 (text "Outputing asm to" <+> text filenm) + debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm) + let ncg_config = initNCGConfig dflags this_mod {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen logger dflags this_mod location h ncg_uniqs cmm_stream + nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream {- ************************************************************************ @@ -226,7 +226,7 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs createDirectoryIfMissing True (takeDirectory stub_h) - dumpIfSet_dyn logger dflags Opt_D_dump_foreign + putDumpFileMaybe logger Opt_D_dump_foreign "Foreign export header file" FormatC stub_h_output_d @@ -251,7 +251,7 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs <- outputForeignStubs_help stub_h stub_h_output_w ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr - dumpIfSet_dyn logger dflags Opt_D_dump_foreign + putDumpFileMaybe logger Opt_D_dump_foreign "Foreign export stubs" FormatC stub_c_output_d stub_c_file_exists diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs index 7a96271403..2d4135a847 100644 --- a/compiler/GHC/Driver/Config.hs +++ b/compiler/GHC/Driver/Config.hs @@ -2,7 +2,6 @@ module GHC.Driver.Config ( initOptCoercionOpts , initSimpleOpts - , initParserOpts , initBCOOpts , initEvalOpts ) @@ -13,9 +12,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Core.SimpleOpt import GHC.Core.Coercion.Opt -import GHC.Parser.Lexer import GHC.Runtime.Interpreter (BCOOpts(..)) -import GHC.Utils.Error (mkPlainMsgEnvelope) import GHCi.Message (EvalOpts(..)) import GHC.Conc (getNumProcessors) @@ -34,18 +31,6 @@ initSimpleOpts dflags = SimpleOpts , so_co_opts = initOptCoercionOpts dflags } --- | Extracts the flag information needed for parsing -initParserOpts :: DynFlags -> ParserOpts -initParserOpts = - mkParserOpts - <$> warningFlags - <*> extensionFlags - <*> mkPlainMsgEnvelope - <*> safeImportsOn - <*> gopt Opt_Haddock - <*> gopt Opt_KeepRawTokenStream - <*> const True - -- | Extract BCO options from DynFlags initBCOOpts :: DynFlags -> IO BCOOpts initBCOOpts dflags = do diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs new file mode 100644 index 0000000000..91be35832a --- /dev/null +++ b/compiler/GHC/Driver/Config/CmmToAsm.hs @@ -0,0 +1,70 @@ +module GHC.Driver.Config.CmmToAsm + ( initNCGConfig + ) +where + +import GHC.Prelude + +import GHC.Driver.Session + +import GHC.Platform +import GHC.Unit.Types (Module) +import GHC.CmmToAsm.Config +import GHC.Utils.Outputable + +-- | Initialize the native code generator configuration from the DynFlags +initNCGConfig :: DynFlags -> Module -> NCGConfig +initNCGConfig dflags this_mod = NCGConfig + { ncgPlatform = targetPlatform dflags + , ncgThisModule = this_mod + , ncgAsmContext = initSDocContext dflags (PprCode AsmStyle) + , ncgProcAlignment = cmmProcAlignment dflags + , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , ncgPIC = positionIndependent dflags + , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags + , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags + , ncgSplitSections = gopt Opt_SplitSections dflags + , ncgRegsIterative = gopt Opt_RegsIterative dflags + , ncgRegsGraph = gopt Opt_RegsGraph dflags + , ncgAsmLinting = gopt Opt_DoAsmLinting dflags + , ncgCfgWeights = cfgWeights dflags + , ncgCfgBlockLayout = gopt Opt_CfgBlocklayout dflags + , ncgCfgWeightlessLayout = gopt Opt_WeightlessBlocklayout dflags + + -- With -O1 and greater, the cmmSink pass does constant-folding, so + -- we don't need to do it again in the native code generator. + , ncgDoConstantFolding = optLevel dflags < 1 + + , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags + , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags + , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags + , ncgBmiVersion = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags + ArchX86 -> bmiVersion dflags + _ -> Nothing + + -- We assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + , ncgSseVersion = + let v | sseVersion dflags < Just SSE2 = Just SSE2 + | otherwise = sseVersion dflags + in case platformArch (targetPlatform dflags) of + ArchX86_64 -> v + ArchX86 -> v + _ -> Nothing + + , ncgDwarfEnabled = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64 + , ncgDwarfUnwindings = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 + , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1. + , ncgDwarfSourceNotes = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3 + , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags + , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags + , ncgEnableShortcutting = gopt Opt_AsmShortcutting dflags + , ncgComputeUnwinding = debugLevel dflags > 0 + } diff --git a/compiler/GHC/Driver/Config/Logger.hs b/compiler/GHC/Driver/Config/Logger.hs new file mode 100644 index 0000000000..c448a7d58e --- /dev/null +++ b/compiler/GHC/Driver/Config/Logger.hs @@ -0,0 +1,29 @@ +module GHC.Driver.Config.Logger + ( initLogFlags + ) +where + +import GHC.Prelude + +import GHC.Driver.Session + +import GHC.Utils.Logger (LogFlags (..)) +import GHC.Utils.Outputable + +-- | Initialize LogFlags from DynFlags +initLogFlags :: DynFlags -> LogFlags +initLogFlags dflags = LogFlags + { log_default_user_context = initSDocContext dflags defaultUserStyle + , log_default_dump_context = initSDocContext dflags defaultDumpStyle + , log_dump_flags = dumpFlags dflags + , log_show_caret = gopt Opt_DiagnosticsShowCaret dflags + , log_show_warn_groups = gopt Opt_ShowWarnGroups dflags + , log_enable_timestamps = not (gopt Opt_SuppressTimestamps dflags) + , log_dump_to_file = gopt Opt_DumpToFile dflags + , log_dump_dir = dumpDir dflags + , log_dump_prefix = dumpPrefix dflags + , log_dump_prefix_override = dumpPrefixForce dflags + , log_enable_debug = not (hasNoDebugOutput dflags) + , log_verbosity = verbosity dflags + } + diff --git a/compiler/GHC/Driver/Config/Parser.hs b/compiler/GHC/Driver/Config/Parser.hs new file mode 100644 index 0000000000..bc4c589bf8 --- /dev/null +++ b/compiler/GHC/Driver/Config/Parser.hs @@ -0,0 +1,24 @@ +module GHC.Driver.Config.Parser + ( initParserOpts + ) +where + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Utils.Error + +import GHC.Parser.Lexer + +-- | Extracts the flags needed for parsing +initParserOpts :: DynFlags -> ParserOpts +initParserOpts = + mkParserOpts + <$> warningFlags + <*> extensionFlags + <*> mkPlainMsgEnvelope + <*> safeImportsOn + <*> gopt Opt_Haddock + <*> gopt Opt_KeepRawTokenStream + <*> const True -- use LINE/COLUMN to update the internal location + diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 1948a91927..6606f551e5 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -3,10 +3,13 @@ module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hscUpdateFlags + , hscSetFlags , hsc_home_unit , hsc_units , hsc_HPT , hscUpdateHPT + , hscUpdateLoggerFlags , runHsc , runHsc' , mkInteractiveHscEnv @@ -33,6 +36,7 @@ import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Driver.Errors.Types ( GhcMessage ) +import GHC.Driver.Config.Logger (initLogFlags) import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types (Interp) @@ -67,6 +71,7 @@ import GHC.Utils.Outputable import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Unique.FM import Data.IORef @@ -75,7 +80,8 @@ import qualified Data.Set as Set runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyMessages - printOrThrowDiagnostics (hsc_logger hsc_env) (hsc_dflags hsc_env) w + let dflags = hsc_dflags hsc_env + printOrThrowDiagnostics (hsc_logger hsc_env) dflags w return a runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage) @@ -85,9 +91,8 @@ runHsc' hsc_env (Hsc hsc) = hsc hsc_env emptyMessages mkInteractiveHscEnv :: HscEnv -> HscEnv mkInteractiveHscEnv hsc_env = let ic = hsc_IC hsc_env - in hsc_env { hsc_dflags = ic_dflags ic - , hsc_plugins = ic_plugins ic - } + in hscSetFlags (ic_dflags ic) $ + hsc_env { hsc_plugins = ic_plugins ic } -- | A variant of runHsc that switches in the DynFlags and Plugins from the -- InteractiveContext before running the Hsc computation. @@ -354,3 +359,20 @@ hscInterp :: HscEnv -> Interp hscInterp hsc_env = case hsc_interp hsc_env of Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter") Just i -> i + +-- | Update the LogFlags of the Log in hsc_logger from the DynFlags in +-- hsc_dflags. You need to call this when DynFlags are modified. +hscUpdateLoggerFlags :: HscEnv -> HscEnv +hscUpdateLoggerFlags h = h + { hsc_logger = setLogFlags (hsc_logger h) (initLogFlags (hsc_dflags h)) } + +-- | Update Flags +hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv +hscUpdateFlags f h = hscSetFlags (f (hsc_dflags h)) h + +-- | Set Flags +hscSetFlags :: DynFlags -> HscEnv -> HscEnv +hscSetFlags dflags h = + -- update LogFlags from the new DynFlags + hscUpdateLoggerFlags + $ h { hsc_dflags = dflags } diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs index d672de33e6..c0cb9c9cda 100644 --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -6,7 +6,7 @@ module GHC.Driver.Env.Types import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks -import GHC.Driver.Session ( DynFlags, HasDynFlags(..) ) +import GHC.Driver.Session ( DynFlags, ContainsDynFlags(..), HasDynFlags(..) ) import GHC.Prelude import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types ( Interp ) @@ -45,6 +45,9 @@ instance MonadIO Hsc where instance HasDynFlags Hsc where getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) +instance ContainsDynFlags HscEnv where + extractDynFlags h = hsc_dflags h + instance HasLogger Hsc where getLogger = Hsc $ \e w -> return (hsc_logger e, w) @@ -114,7 +117,11 @@ data HscEnv -- from the DynFlags. , hsc_logger :: !Logger - -- ^ Logger + -- ^ Logger with its flags. + -- + -- Don't forget to update the logger flags if the logging + -- related DynFlags change. Or better, use hscSetFlags setter + -- which does it. , hsc_hooks :: !Hooks -- ^ Hooks diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 157fd77735..98cb0eef93 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -21,7 +21,7 @@ printMessages :: Diagnostic a => Logger -> DynFlags -> Messages a -> IO () printMessages logger dflags msgs = sequence_ [ let style = mkErrStyle unqual ctx = initSDocContext dflags style - in putLogMsg logger dflags (MCDiagnostic sev . diagnosticReason $ dia) s $ + in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $ withPprStyle style (messageWithHints ctx dia) | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = dia, diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 19f730ed19..dc9c19a52e 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -135,6 +135,7 @@ data DumpFlag | Opt_D_ppr_debug | Opt_D_no_debug_output | Opt_D_dump_faststrings + | Opt_D_faststring_stats deriving (Eq, Show, Enum) -- | Enumerates the simple on-or-off dynamic flags @@ -142,7 +143,6 @@ data GeneralFlag -- See Note [Updating flag description in the User's Guide] = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. - | Opt_D_faststring_stats | Opt_D_dump_minimal_imports | Opt_DoCoreLinting | Opt_DoLinearCoreLinting diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 3c6bacdf6a..2f40d7a00b 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -101,7 +101,8 @@ import GHC.Driver.Env import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput -import GHC.Driver.Config +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Hooks import GHC.Runtime.Context @@ -250,7 +251,7 @@ newHscEnv dflags = do tmpfs <- initTmpFs unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags) return HscEnv { hsc_dflags = dflags - , hsc_logger = logger + , hsc_logger = setLogFlags logger (initLogFlags dflags) , hsc_targets = [] , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags @@ -391,7 +392,7 @@ hscParse' mod_summary | otherwise = do dflags <- getDynFlags logger <- getLogger - {-# SCC "Parser" #-} withTiming logger dflags + {-# SCC "Parser" #-} withTiming logger (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) (const ()) $ do let src_filename = ms_hspp_file mod_summary @@ -416,13 +417,13 @@ hscParse' mod_summary POk pst rdr_module -> do let (warns, errs) = getMessages pst logDiagnostics (GhcPsMessage <$> warns) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rdr_module) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics" + liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics" FormatText (ppSourceStats False rdr_module) when (not $ isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs) @@ -472,7 +473,7 @@ extract_renamed_stuff mod_summary tc_result = do dflags <- getDynFlags logger <- getLogger - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer" + liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer" FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info) -- Create HIE files @@ -482,7 +483,7 @@ extract_renamed_stuff mod_summary tc_result = do hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) let out_file = ml_hie_file $ ms_location mod_summary liftIO $ writeHieFile out_file hieFile - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) -- Validate HIE files when (gopt Opt_ValidateHie dflags) $ do @@ -490,18 +491,19 @@ extract_renamed_stuff mod_summary tc_result = do liftIO $ do -- Validate Scopes case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of - [] -> putMsg logger dflags $ text "Got valid scopes" + [] -> putMsg logger $ text "Got valid scopes" xs -> do - putMsg logger dflags $ text "Got invalid scopes" - mapM_ (putMsg logger dflags) xs + putMsg logger $ text "Got invalid scopes" + mapM_ (putMsg logger) xs -- Roundtrip testing file' <- readHieFile (hsc_NC hs_env) out_file case diffFile hieFile (hie_file_result file') of [] -> - putMsg logger dflags $ text "Got no roundtrip errors" + putMsg logger $ text "Got no roundtrip errors" xs -> do - putMsg logger dflags $ text "Got roundtrip errors" - mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs + putMsg logger $ text "Got roundtrip errors" + let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug) + mapM_ (putMsg logger') xs return rn_info @@ -633,8 +635,8 @@ hscDesugar' mod_location tc_result = do -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. -makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails -makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result +makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails +makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result {- ********************************************************************** @@ -978,12 +980,13 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do write_iface dflags' iface = let !iface_name = buildIfName (hiSuf dflags') + profile = targetProfile dflags' in {-# SCC "writeIface" #-} - withTiming logger dflags' + withTiming logger (text "WriteIface"<+>brackets (text iface_name)) (const ()) - (writeIface logger dflags' iface_name iface) + (writeIface logger profile iface_name iface) when (write_interface || force_write_interface) $ do @@ -1004,7 +1007,7 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do dt <- dynamicTooState dflags - when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags $ + when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $ hang (text "Writing interface(s):") 2 $ vcat [ text "Kind:" <+> if is_simple then text "simple" else text "full" , text "Hash change:" <+> ppr (not no_change) @@ -1060,17 +1063,11 @@ genModDetails hsc_env old_iface -- Progress displayers. -------------------------------------------------------------- -oneShotMsg :: HscEnv -> RecompileRequired -> IO () -oneShotMsg hsc_env recomp = +oneShotMsg :: Logger -> RecompileRequired -> IO () +oneShotMsg logger recomp = case recomp of - UpToDate -> - compilationProgressMsg logger dflags $ - text "compilation IS NOT required" - _ -> - return () - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env + UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" + _ -> return () batchMsg :: Messager batchMsg hsc_env mod_index recomp node = case node of @@ -1078,21 +1075,21 @@ batchMsg hsc_env mod_index recomp node = case node of case recomp of MustCompile -> showMsg (text "Instantiating ") empty UpToDate - | verbosity dflags >= 2 -> showMsg (text "Skipping ") empty + | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty | otherwise -> return () RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]") ModuleNode _ -> case recomp of MustCompile -> showMsg (text "Compiling ") empty UpToDate - | verbosity dflags >= 2 -> showMsg (text "Skipping ") empty + | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty | otherwise -> return () RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]") where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env showMsg msg reason = - compilationProgressMsg logger dflags $ + compilationProgressMsg logger $ (showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node) <> reason @@ -1518,9 +1515,9 @@ hscSimplify' plugins ds_result = do hsc_env <- getHscEnv hsc_env_with_plugins <- if null plugins -- fast path then return hsc_env - else liftIO $ flip initializePlugins (Just $ mg_mnwib ds_result) $ hsc_env - { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins - } + else liftIO $ flip initializePlugins (Just $ mg_mnwib ds_result) + $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins) + hsc_env {-# SCC "Core2Core" #-} liftIO $ core2core hsc_env_with_plugins ds_result @@ -1544,7 +1541,8 @@ hscSimpleIface' :: TcGblEnv -> Hsc (ModIface, Maybe Fingerprint, ModDetails) hscSimpleIface' tc_result summary mb_old_iface = do hsc_env <- getHscEnv - details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + logger <- getLogger + details <- liftIO $ mkBootModDetailsTc logger tc_result safe_mode <- hscGetSafeMode tc_result new_iface <- {-# SCC "MkFinalIface" #-} @@ -1576,6 +1574,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env tmpfs = hsc_tmpfs hsc_env + profile = targetProfile dflags data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes @@ -1590,7 +1589,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do ----------------- Convert to STG ------------------ (stg_binds, denv, (caf_ccs, caf_cc_stacks)) <- {-# SCC "CoreToStg" #-} - withTiming logger dflags + withTiming logger (text "CoreToStg"<+>brackets (ppr this_mod)) (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ()) (myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds) @@ -1608,7 +1607,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do -- top-level function, so showPass isn't very useful here. -- Hence we have one showPass for the whole backend, the -- next showPass after this will be "Assembler". - withTiming logger dflags + withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) $ do cmms <- {-# SCC "StgToCmm" #-} @@ -1619,12 +1618,12 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger dflags cmms + Nothing -> cmmToRawCmm logger profile cmms Just h -> h dflags (Just this_mod) cmms let dump a = do unless (null a) $ - dumpIfSet_dyn logger dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) + putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1681,6 +1680,7 @@ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath) hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let profile = targetProfile dflags let hooks = hsc_hooks hsc_env let tmpfs = hsc_tmpfs hsc_env home_unit = hsc_home_unit hsc_env @@ -1691,12 +1691,12 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do cmm_mod = mkHomeModule home_unit mod_name (cmm, ents) <- ioMsgMaybe $ do - (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) + (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags cmm_mod home_unit filename let msgs = warns `unionMessages` errs return (GhcPsMessage <$> msgs, cmm) liftIO $ do - dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) + putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) -- Compile decls in Cmm files one decl at a time, to avoid re-ordering -- them in SRT analysis. @@ -1708,12 +1708,12 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm unless (null cmmgroup) $ - dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" + putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform cmmgroup) rawCmms <- case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger dflags (Stream.yield cmmgroup) - Just h -> h dflags Nothing (Stream.yield cmmgroup) + Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) + Just h -> h dflags Nothing (Stream.yield cmmgroup) let foreign_stubs _ = let ip_init = ipInitCode dflags cmm_mod ents @@ -1767,7 +1767,7 @@ doCodeGen hsc_env this_mod denv data_tycons let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds - dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) let stg_to_cmm = case stgToCmmHook hooks of Nothing -> StgToCmm.codeGen logger tmpfs @@ -1785,7 +1785,7 @@ doCodeGen hsc_env this_mod denv data_tycons let dump1 a = do unless (null a) $ - dumpIfSet_dyn logger dflags Opt_D_dump_cmm_from_stg + putDumpFileMaybe logger Opt_D_dump_cmm_from_stg "Cmm produced by codegen" FormatCMM (pdoc platform a) return a @@ -1802,7 +1802,7 @@ doCodeGen hsc_env this_mod denv data_tycons dump2 a = do unless (null a) $ - dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) + putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a return (Stream.mapM dump2 pipeline_stream) @@ -2114,7 +2114,7 @@ hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int hscParseThingWithLocation source linenumber parser str = do dflags <- getDynFlags logger <- getLogger - withTiming logger dflags + withTiming logger (text "Parser [source]") (const ()) $ {-# SCC "Parser" #-} do @@ -2126,9 +2126,9 @@ hscParseThingWithLocation source linenumber parser str = do handleWarningsThrowErrors (getMessages pst) POk pst thing -> do logWarningsReportErrors (getMessages pst) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" FormatHaskell (ppr thing) - liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing) return thing @@ -2192,15 +2192,13 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr dumpIfaceStats :: HscEnv -> IO () dumpIfaceStats hsc_env = do - eps <- hscEPS hsc_env - dumpIfSet logger dflags (dump_if_trace || dump_rn_stats) - "Interface statistics" - (ifaceStats eps) - where - dflags = hsc_dflags hsc_env + eps <- hscEPS hsc_env + let logger = hsc_logger hsc_env - dump_rn_stats = dopt Opt_D_dump_rn_stats dflags - dump_if_trace = dopt Opt_D_dump_if_trace dflags + dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats + dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace + when (dump_if_trace || dump_rn_stats) $ + logDumpMsg logger "Interface statistics" (ifaceStats eps) {- ********************************************************************** diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index a76c128dbe..c46d83224f 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -51,7 +51,8 @@ import GHC.Linker.Types import GHC.Runtime.Context -import GHC.Driver.Config +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Session @@ -206,13 +207,12 @@ depanalPartial depanalPartial excluded_mods allow_dup_roots = do hsc_env <- getSession let - dflags = hsc_dflags hsc_env targets = hsc_targets hsc_env old_graph = hsc_mod_graph hsc_env logger = hsc_logger hsc_env - withTiming logger dflags (text "Chasing dependencies") (const ()) $ do - liftIO $ debugTraceMsg logger dflags 2 (hcat [ + withTiming logger (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg logger 2 (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))]) @@ -435,7 +435,7 @@ load' how_much mHscMessage mod_graph = do checkMod m and_then | m `elementOfUniqSet` all_home_mods = and_then | otherwise = do - liftIO $ errorMsg logger dflags + liftIO $ errorMsg logger (text "no such module:" <+> quotes (ppr m)) return Failed @@ -508,8 +508,8 @@ load' how_much mHscMessage mod_graph = do mg = partial_mg - liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) + liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) n_jobs <- case parMakeCount dflags of Nothing -> liftIO getNumProcessors @@ -535,7 +535,7 @@ load' how_much mHscMessage mod_graph = do then -- Easy; just relink it all. - do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep completely successful.") + do liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.") -- Clean up after ourselves hsc_env1 <- getSession @@ -567,7 +567,7 @@ load' how_much mHscMessage mod_graph = do if ghcLink dflags == LinkBinary && isJust ofile && not do_linking then do - liftIO $ errorMsg logger dflags $ text + liftIO $ errorMsg logger $ text ("output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ @@ -581,7 +581,7 @@ load' how_much mHscMessage mod_graph = do -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep partially successful.") + do liftIO $ debugTraceMsg logger 2 (text "Upsweep partially successful.") let modsDone_names = map (ms_mod . emsModSummary) modsDone @@ -720,7 +720,7 @@ guessOutputFile = modifySession $ \env -> in case outputFile_ dflags of Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile_ = name_exe } } + Nothing -> hscSetFlags (dflags { outputFile_ = name_exe }) env -- ----------------------------------------------------------------------------- -- @@ -1032,7 +1032,7 @@ parUpsweep n_jobs mHscMessage old_hpt sccs = do , show mod_idx ] ] - -- Replace the default log_action with one that writes each + -- Replace the default logger with one that writes each -- message to the module's log_queue. The main thread will -- deal with synchronously printing these messages. let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger @@ -1045,15 +1045,18 @@ parUpsweep n_jobs mHscMessage old_hpt sccs = do -- Unmask asynchronous exceptions and perform the thread-local -- work to compile the module (see parUpsweep_one). - m_res <- MC.try $ unmask $ prettyPrintGhcErrors dflags $ + m_res <- MC.try $ unmask $ prettyPrintGhcErrors logger $ case mod of InstantiationNode iuid -> do hsc_env <- readMVar hsc_env_var liftIO $ upsweep_inst hsc_env mHscMessage mod_idx (length sccs) iuid pure Succeeded - ModuleNode ems -> - parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops - lcl_logger lcl_tmpfs dflags (hsc_home_unit hsc_env) + ModuleNode ems -> do + let summary = emsModSummary ems + let lcl_dflags = ms_hspp_opts summary + let lcl_logger' = setLogFlags lcl_logger (initLogFlags lcl_dflags) + parUpsweep_one summary home_mod_map comp_graph_loops + lcl_logger' lcl_tmpfs dflags (hsc_home_unit hsc_env) mHscMessage par_sem hsc_env_var old_hpt_var mod_idx (length sccs) @@ -1066,7 +1069,7 @@ parUpsweep n_jobs mHscMessage old_hpt sccs = do -- interrupt, and the user doesn't have to be informed -- about that. when (fromException exc /= Just ThreadKilled) - (errorMsg lcl_logger dflags (text (show exc))) + (errorMsg lcl_logger (text (show exc))) return Failed -- Populate the result MVar. @@ -1092,7 +1095,7 @@ parUpsweep n_jobs mHscMessage old_hpt sccs = do -- Loop over each module in the compilation graph in order, printing -- each message from its log_queue. forM comp_graph $ \(mod,mvar,log_queue) -> do - printLogs logger dflags log_queue + printLogs logger log_queue result <- readMVar mvar if succeeded result then return (Just mod) else return Nothing @@ -1105,7 +1108,7 @@ parUpsweep n_jobs mHscMessage old_hpt sccs = do -- of the upsweep. case cycle of Just mss -> do - liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr mss) + liftIO $ fatalErrorMsg logger (cyclicModuleErr mss) return (Failed,ok_results) Nothing -> do let success_flag = successIf (all isJust results) @@ -1124,10 +1127,9 @@ parUpsweep n_jobs mHscMessage old_hpt sccs = do parLogAction log_queue _dflags !msgClass !srcSpan !msg = writeLogQueue log_queue (Just (msgClass,srcSpan,msg)) - -- Print each message from the log_queue using the log_action from the - -- session's DynFlags. - printLogs :: Logger -> DynFlags -> LogQueue -> IO () - printLogs !logger !dflags (LogQueue ref sem) = read_msgs + -- Print each message from the log_queue using the global logger + printLogs :: Logger -> LogQueue -> IO () + printLogs !logger (LogQueue ref sem) = read_msgs where read_msgs = do takeMVar sem msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) @@ -1136,7 +1138,7 @@ parUpsweep n_jobs mHscMessage old_hpt sccs = do print_loop [] = read_msgs print_loop (x:xs) = case x of Just (msgClass,srcSpan,msg) -> do - putLogMsg logger dflags msgClass srcSpan msg + logMsg logger msgClass srcSpan msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () @@ -1297,7 +1299,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags -- EXCEPT the loop closer. However, our precomputed -- SCCs include the loop closer, so we have to filter -- it out. - Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $ + Just loop -> typecheckLoop lcl_hsc_env' $ filter (/= moduleName (gwib_mod this_build_mod)) $ map (moduleName . gwib_mod) loop @@ -1327,7 +1329,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags -- closer! hsc_env'' <- case finish_loop of Nothing -> return hsc_env' - Just loop -> typecheckLoop lcl_dflags hsc_env' $ + Just loop -> typecheckLoop hsc_env' $ map (moduleName . gwib_mod) loop return (hsc_env'', localize_hsc_env hsc_env'') @@ -1391,9 +1393,8 @@ upsweep mHscMessage old_hpt sccs = do nmods' = nmods - length dropped_ms when (not $ null dropped_ms) $ do - dflags <- getSessionDynFlags logger <- getLogger - liftIO $ debugTraceMsg logger dflags 2 (keepGoingPruneErr dropped_ms) + liftIO $ debugTraceMsg logger 2 (keepGoingPruneErr $ dropped_ms) (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' return (Failed, done') @@ -1412,7 +1413,7 @@ upsweep mHscMessage old_hpt sccs = do (CyclicSCC ms : mods) mod_index nmods = do dflags <- getSessionDynFlags logger <- getLogger - liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr ms) + liftIO $ fatalErrorMsg logger (cyclicModuleErr ms) if gopt Opt_KeepGoing dflags then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods else return (Failed, done) @@ -1745,7 +1746,7 @@ reTypecheckLoop hsc_env ms graph let l = emsModSummary ems guard $ not $ isBootSummary l == IsBoot && ms_mod l == ms_mod ms pure l - = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) + = typecheckLoop hsc_env (map ms_mod_name non_boot) | otherwise = return hsc_env where @@ -1805,9 +1806,9 @@ getModLoop ms graph appearsAsBoot -- NB: sometimes mods has duplicates; this is harmless because -- any duplicates get clobbered in addListToHpt and never get forced. -typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv -typecheckLoop dflags hsc_env mods = do - debugTraceMsg logger dflags 2 $ +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + debugTraceMsg logger 2 $ text "Re-typechecking loop: " <> ppr mods new_hpt <- fixIO $ \new_hpt -> do @@ -2065,7 +2066,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - roots = hsc_targets hsc_env + roots = hsc_targets hsc_env old_summary_map :: ModNodeMap ExtendedModSummary old_summary_map = mkNodeMap old_summaries @@ -2625,7 +2626,7 @@ withDeferredDiagnostics f = do logger <- getLogger let deferDiagnostics _dflags !msgClass !srcSpan !msg = do - let action = putLogMsg logger dflags msgClass srcSpan msg + let action = logMsg logger msgClass srcSpan msg case msgClass of MCDiagnostic SevWarning _reason -> atomicModifyIORef' warnings $ \i -> (action: i, ()) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index f654d0a7fa..8f53d2f598 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -96,7 +96,7 @@ doMkDependHS srcs = do let sorted = GHC.topSortModuleGraph False module_graph Nothing -- Print out the dependencies if wanted - liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted) + liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted) -- Process them one by one, dumping results into makefile -- and complaining about cycles @@ -105,10 +105,10 @@ doMkDependHS srcs = do mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted -- If -ddump-mod-cycles, show cycles in the module graph - liftIO $ dumpModCycles logger dflags module_graph + liftIO $ dumpModCycles logger module_graph -- Tidy up - liftIO $ endMkDependHS logger dflags files + liftIO $ endMkDependHS logger files -- Unconditional exiting is a bad idea. If an error occurs we'll get an --exception; if that is not caught it's fine, but at least we have a @@ -347,9 +347,9 @@ insertSuffixes file_name extras -- ----------------------------------------------------------------- -endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO () +endMkDependHS :: Logger -> MkDepFiles -> IO () -endMkDependHS logger dflags +endMkDependHS logger (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) = do @@ -367,11 +367,11 @@ endMkDependHS logger dflags -- Create a backup of the original makefile when (isJust makefile_hdl) $ do - showPass logger dflags ("Backing up " ++ makefile) + showPass logger ("Backing up " ++ makefile) SysTools.copyFile makefile (makefile++".bak") -- Copy the new makefile in place - showPass logger dflags "Installing new makefile" + showPass logger "Installing new makefile" SysTools.copyFile tmp_file makefile @@ -379,16 +379,16 @@ endMkDependHS logger dflags -- Module cycles ----------------------------------------------------------------- -dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO () -dumpModCycles logger dflags module_graph - | not (dopt Opt_D_dump_mod_cycles dflags) +dumpModCycles :: Logger -> ModuleGraph -> IO () +dumpModCycles logger module_graph + | not (logHasDumpFlag logger Opt_D_dump_mod_cycles) = return () | null cycles - = putMsg logger dflags (text "No module cycles") + = putMsg logger (text "No module cycles") | otherwise - = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles) + = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles) where topoSort = filterToposortToModules $ GHC.topSortModuleGraph True module_graph Nothing diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 873cbfac4e..244ac04a0f 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -123,23 +123,20 @@ popLogHookM = modifyLogger popLogHook -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m () putMsgM doc = do - dflags <- getDynFlags logger <- getLogger - liftIO $ putMsg logger dflags doc + liftIO $ putMsg logger doc -- | Put a log message putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m () putLogMsgM msg_class loc doc = do - dflags <- getDynFlags logger <- getLogger - liftIO $ putLogMsg logger dflags msg_class loc doc + liftIO $ logMsg logger msg_class loc doc -- | Time an action withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b withTimingM doc force action = do logger <- getLogger - dflags <- getDynFlags - withTiming logger dflags doc force action + withTiming logger doc force action -- ----------------------------------------------------------------------------- -- | A monad that allows logging of diagnostics. diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 205c767aed..7c2c986967 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -49,7 +49,7 @@ import GHC.Driver.Env hiding ( Hsc ) import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Pipeline.Monad -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Phases import GHC.Driver.Session import GHC.Driver.Backend @@ -211,7 +211,7 @@ compileOne' m_tc_result mHscMessage hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable = do - debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp) + debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp) let flags = hsc_dflags hsc_env0 in do unless (gopt Opt_KeepHiFiles flags) $ @@ -242,15 +242,15 @@ compileOne' m_tc_result mHscMessage (tc_result, warnings) <- hscTypecheckAndGetWarnings plugin_hsc_env summary runPostTc tc_result warnings mb_old_hash - where dflags0 = ms_hspp_opts summary + where lcl_dflags = ms_hspp_opts summary location = ms_location summary input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary mod_graph = hsc_mod_graph hsc_env0 needsLinker = needsTemplateHaskellOrQQ mod_graph - isDynWay = any (== WayDyn) (ways dflags0) - isProfWay = any (== WayProf) (ways dflags0) - internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) + isDynWay = any (== WayDyn) (ways lcl_dflags) + isProfWay = any (== WayProf) (ways lcl_dflags) + internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) logger = hsc_logger hsc_env0 tmpfs = hsc_tmpfs hsc_env0 @@ -260,8 +260,8 @@ compileOne' m_tc_result mHscMessage -- when using -fexternal-interpreter. dflags1 = if hostIsDynamic && internalInterpreter && not isDynWay && not isProfWay && needsLinker - then gopt_set dflags0 Opt_BuildDynamicToo - else dflags0 + then gopt_set lcl_dflags Opt_BuildDynamicToo + else lcl_dflags -- #16331 - when no "internal interpreter" is available but we -- need to process some TemplateHaskell or QuasiQuotes, we automatically @@ -293,7 +293,7 @@ compileOne' m_tc_result mHscMessage | otherwise = (backend dflags, dflags2) dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] } - hsc_env = hsc_env0 {hsc_dflags = dflags} + hsc_env = hscSetFlags dflags hsc_env0 always_do_basic_recompilation_check = case bcknd of Interpreter -> True @@ -524,11 +524,11 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt -- the linkables to link linkables = map (expectJust "link".hm_linkable) home_mod_infos - debugTraceMsg logger dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) -- check for the -no-link flag if isNoLink (ghcLink dflags) - then do debugTraceMsg logger dflags 3 (text "link(batch): linking omitted (-c flag given).") + then do debugTraceMsg logger 3 (text "link(batch): linking omitted (-c flag given).") return Succeeded else do @@ -540,11 +540,11 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps if not (gopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg logger dflags 2 (text exe_file <+> text "is up to date, linking not required.") + then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.") return Succeeded else do - compilationProgressMsg logger dflags (text "Linking " <> text exe_file <> text " ...") + compilationProgressMsg logger (text "Linking " <> text exe_file <> text " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of @@ -554,13 +554,13 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt other -> panicBadLink other link dflags unit_env obj_files pkg_deps - debugTraceMsg logger dflags 3 (text "link: done") + debugTraceMsg logger 3 (text "link: done") -- linkBinary only returns if it succeeds return Succeeded | otherwise - = do debugTraceMsg logger dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + = do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$ text " Main.main not exported; not linking.") return Succeeded @@ -694,13 +694,11 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) mb_basename output maybe_loc foreign_os = do let - dflags0 = hsc_dflags hsc_env0 - -- Decide where dump files should go based on the pipeline output - dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } - hsc_env = hsc_env0 {hsc_dflags = dflags} - logger = hsc_logger hsc_env - tmpfs = hsc_tmpfs hsc_env + hsc_env = hscUpdateFlags (\dflags -> dflags { dumpPrefix = Just (basename ++ ".")}) hsc_env0 + logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + dflags = hsc_dflags hsc_env (input_basename, suffix) = splitExtension input_fn suffix' = drop 1 suffix -- strip off the . @@ -760,11 +758,10 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) return fn (_, _) -> return input_fn - debugTraceMsg logger dflags 4 (text "Running the pipeline") + debugTraceMsg logger 4 (text "Running the pipeline") r <- runPipeline' start_phase hsc_env env input_fn' maybe_loc foreign_os - let dflags = hsc_dflags hsc_env when isHaskellishFile $ dynamicTooState dflags >>= \case DT_Dont -> return () @@ -790,7 +787,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) | OSMinGW32 <- platformOS (targetPlatform dflags) -> return () | otherwise -> do - debugTraceMsg logger dflags 4 + debugTraceMsg logger 4 (text "Running the full pipeline again for -dynamic-too") let dflags0 = flip gopt_unset Opt_BuildDynamicToo $ setDynamicNow @@ -804,10 +801,8 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) , ue_units = unit_state , ue_unit_dbs = Just dbs } - let hsc_env'' = hsc_env' - { hsc_dflags = dflags1 - , hsc_unit_env = unit_env - } + let hsc_env'' = hscSetFlags dflags1 + $ hsc_env' { hsc_unit_env = unit_env } _ <- runPipeline' start_phase hsc_env'' env input_fn' maybe_loc foreign_os return () @@ -864,7 +859,7 @@ pipeLoop phase input_fn = do when (final_fn /= input_fn) $ do let msg = "Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'" line_prag = "{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n" - liftIO $ showPass logger dflags msg + liftIO $ showPass logger msg liftIO $ copyWithHeader line_prag input_fn final_fn return final_fn @@ -878,7 +873,7 @@ pipeLoop phase input_fn = do " but I wanted to stop at phase " ++ show stopPhase) _ - -> do liftIO $ debugTraceMsg logger dflags 4 + -> do liftIO $ debugTraceMsg logger 4 (text "Running phase" <+> ppr phase) case phase of @@ -1140,16 +1135,17 @@ runPhase (RealPhase (Unlit sf)) input_fn = do runPhase (RealPhase (Cpp sf)) input_fn = do dflags0 <- getDynFlags - logger <- getLogger src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts setDynFlags dflags1 liftIO $ checkProcessArgsResult unhandled_flags + if not (xopt LangExt.Cpp dflags1) then do -- we have to be careful to emit warnings only once. - unless (gopt Opt_Pp dflags1) $ + unless (gopt Opt_Pp dflags1) $ do + logger <- getLogger liftIO $ handleFlagWarnings logger dflags1 warns -- no need to preprocess CPP, just pass input file along @@ -1158,6 +1154,7 @@ runPhase (RealPhase (Cpp sf)) input_fn else do output_fn <- phaseOutputFilename (HsPp sf) hsc_env <- getPipeSession + logger <- getLogger liftIO $ doCpp logger (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) @@ -1169,13 +1166,13 @@ runPhase (RealPhase (Cpp sf)) input_fn src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts + setDynFlags dflags2 liftIO $ checkProcessArgsResult unhandled_flags - unless (gopt Opt_Pp dflags2) $ + unless (gopt Opt_Pp dflags2) $ do + logger <- getLogger liftIO $ handleFlagWarnings logger dflags2 warns -- the HsPp pass below will emit warnings - setDynFlags dflags2 - return (RealPhase (HsPp sf), output_fn) ------------------------------------------------------------------------------- @@ -1285,7 +1282,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn -- run the compiler! - let msg hsc_env _ what _ = oneShotMsg hsc_env what + let msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what plugin_hsc_env' <- liftIO $ initializePlugins hsc_env' (Just $ ms_mnwib mod_summary) -- Need to set the knot-tying mutable variable for interface @@ -1598,10 +1595,10 @@ runPhase (RealPhase cc_phase) input_fn runPhase (RealPhase (As with_cpp)) input_fn = do hsc_env <- getPipeSession - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let unit_env = hsc_unit_env hsc_env - let platform = ue_platform unit_env + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let unit_env = hsc_unit_env hsc_env + let platform = ue_platform unit_env -- LLVM from version 3.0 onwards doesn't support the OS X system -- assembler, so we use clang as the assembler instead. (#5636) @@ -1665,7 +1662,7 @@ runPhase (RealPhase (As with_cpp)) input_fn , GHC.SysTools.FileOption "" temp_outputFilename ]) - liftIO $ debugTraceMsg logger dflags 4 (text "Running the assembler") + liftIO $ debugTraceMsg logger 4 (text "Running the assembler") runAssembler input_fn output_fn return (RealPhase next_phase, output_fn) @@ -1790,9 +1787,10 @@ runPhase (RealPhase LlvmLlc) input_fn = do runPhase (RealPhase LlvmMangle) input_fn = do let next_phase = As False output_fn <- phaseOutputFilename next_phase - dflags <- getDynFlags + platform <- (ue_platform . hsc_unit_env) <$> getPipeSession logger <- getLogger - liftIO $ llvmFixupAsm logger dflags input_fn output_fn + liftIO $ withTiming logger (text "LLVM Mangler") id $ + llvmFixupAsm platform input_fn output_fn return (RealPhase next_phase, output_fn) ----------------------------------------------------------------------------- @@ -1872,7 +1870,7 @@ getHCFilePackages filename = linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ - putLogMsg logger dflags MCInfo noSrcSpan + logMsg logger MCInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") @@ -1884,7 +1882,7 @@ linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do -- | Run CPP -- --- UnitState is needed to compute MIN_VERSION macros +-- UnitEnv is needed to compute MIN_VERSION macros doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do let hscpp_opts = picPOpts dflags diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index 8440141f2c..3f6716a954 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -144,7 +144,7 @@ instance HasLogger CompPipeline where setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state -> - return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + return (state{ hsc_env = hscSetFlags dflags (hsc_env state)}, ()) setPlugins :: [LoadedPlugin] -> [StaticPlugin] -> CompPipeline () setPlugins dyn static = P $ \_env state -> diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs index b663e8bbff..a43f9eaa1d 100644 --- a/compiler/GHC/Driver/Ppr.hs +++ b/compiler/GHC/Driver/Ppr.hs @@ -13,7 +13,6 @@ module GHC.Driver.Ppr -- ** Trace , warnPprTrace , pprTrace - , pprTraceWithFlags , pprTraceM , pprTraceDebug , pprTraceIt @@ -81,13 +80,6 @@ pprDebugAndThen ctx cont heading pretty_msg doc = sep [heading, nest 2 pretty_msg] -- | If debug output is on, show some 'SDoc' on the screen -pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a -pprTraceWithFlags dflags str doc x - | hasNoDebugOutput dflags = x - | otherwise = pprDebugAndThen (initSDocContext dflags defaultDumpStyle) - trace (text str) doc x - --- | If debug output is on, show some 'SDoc' on the screen pprTrace :: String -> SDoc -> a -> a pprTrace str doc x | unsafeHasNoDebugOutput = x diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index f6095677e4..aa761325d3 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -24,7 +24,7 @@ module GHC.Driver.Session ( WarningFlag(..), DiagnosticReason(..), Language(..), PlatformConstants(..), - FatalMessager, FlushOut(..), FlushErr(..), + FatalMessager, FlushOut(..), ProfAuto(..), glasgowExtsFlags, hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, @@ -150,7 +150,6 @@ module GHC.Driver.Session ( initDynFlags, -- DynFlags -> IO DynFlags defaultFatalMessager, defaultFlushOut, - defaultFlushErr, setOutputFile, setDynOutputFile, setOutputHi, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] @@ -232,7 +231,7 @@ import GHC.Driver.Flags import GHC.Driver.Backend import GHC.Settings.Config import GHC.Utils.CliOption -import {-# SOURCE #-} GHC.Core.Unfold +import GHC.Core.Unfold import GHC.Driver.CmdLine import GHC.Settings.Constants import GHC.Utils.Panic @@ -452,7 +451,6 @@ data DynFlags = DynFlags { simplPhases :: Int, -- ^ Number of simplifier phases maxSimplIterations :: Int, -- ^ Max simplifier iterations ruleCheck :: Maybe String, - inlineCheck :: Maybe String, -- ^ A prefix to report inlining decisions about strictnessBefore :: [Int], -- ^ Additional demand analysis parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel @@ -648,7 +646,6 @@ data DynFlags = DynFlags { ghciHistSize :: Int, flushOut :: FlushOut, - flushErr :: FlushErr, ghcVersionFile :: Maybe FilePath, haddockOptions :: Maybe String, @@ -1122,7 +1119,6 @@ defaultDynFlags mySettings llvmConfig = simplPhases = 2, maxSimplIterations = 4, ruleCheck = Nothing, - inlineCheck = Nothing, binBlobThreshold = 500000, -- 500K is a good default (see #16190) maxRelevantBinds = Just 6, maxValidHoleFits = Just 6, @@ -1252,7 +1248,6 @@ defaultDynFlags mySettings llvmConfig = ghciHistSize = 50, -- keep a log of length 50 by default flushOut = defaultFlushOut, - flushErr = defaultFlushErr, pprUserLength = 5, pprCols = 100, useUnicode = False, @@ -1297,11 +1292,6 @@ newtype FlushOut = FlushOut (IO ()) defaultFlushOut :: FlushOut defaultFlushOut = FlushOut $ hFlush stdout -newtype FlushErr = FlushErr (IO ()) - -defaultFlushErr :: FlushErr -defaultFlushErr = FlushErr $ hFlush stderr - {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -2519,7 +2509,7 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "dsource-stats" (setDumpFlag Opt_D_source_stats) , make_ord_flag defGhcFlag "dverbose-core2core" - (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core) + (NoArg $ setVerbosity (Just 2) >> setDumpFlag' Opt_D_verbose_core2core) , make_ord_flag defGhcFlag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) , make_ord_flag defGhcFlag "ddump-hi" @@ -2559,7 +2549,7 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "dshow-passes" (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) , make_ord_flag defGhcFlag "dfaststring-stats" - (NoArg (setGeneralFlag Opt_D_faststring_stats)) + (setDumpFlag Opt_D_faststring_stats) , make_ord_flag defGhcFlag "dno-llvm-mangler" (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag , make_ord_flag defGhcFlag "dno-typeable-binds" @@ -2718,7 +2708,7 @@ dynamic_flags_deps = [ , make_ord_flag defFlag "drule-check" (sepArg (\s d -> d { ruleCheck = Just s })) , make_ord_flag defFlag "dinline-check" - (sepArg (\s d -> d { inlineCheck = Just s })) + (sepArg (\s d -> d { unfoldingOpts = updateReportPrefix (Just s) (unfoldingOpts d)})) , make_ord_flag defFlag "freduction-depth" (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) , make_ord_flag defFlag "fconstraint-solver-iterations" @@ -4176,9 +4166,6 @@ forceRecompile = do dfs <- liftEwM getCmdLineState force_recomp dfs = isOneShot (ghcMode dfs) -setVerboseCore2Core :: DynP () -setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core - setVerbosity :: Maybe Int -> DynP () setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index e61be3dd69..7ea0619733 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -138,7 +138,7 @@ deSugar hsc_env = do { let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env - ; withTiming logger dflags + ; withTiming logger (text "Desugar"<+>brackets (ppr mod)) (const ()) $ do { -- Desugar the program @@ -189,7 +189,7 @@ deSugar hsc_env = simpleOptPgm simpl_opts mod final_pgm rules_for_imps -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code - ; dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis" + ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps @@ -287,10 +287,9 @@ and Rec the rest. deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - showPass logger dflags "Desugar" + showPass logger "Desugar" -- Do desugaring (tc_msgs, mb_result) <- runTcInteractive hsc_env $ @@ -305,7 +304,7 @@ deSugarExpr hsc_env tc_expr = do case mb_core_expr of Nothing -> return () - Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared" + Just expr -> putDumpFileMaybe logger Opt_D_dump_ds "Desugared" FormatCore (pprCoreExpr expr) -- callers (i.e. ioMsgMaybe) expect that no expression is returned if diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index d876ad39f4..a6b9944292 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -124,7 +124,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds modBreaks <- mkModBreaks hsc_env mod tickCount entries let logger = hsc_logger hsc_env - dumpIfSet_dyn logger dflags Opt_D_dump_ticked "HPC" FormatHaskell + putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell (pprLHsBinds binds1) return (binds1, HpcInfo tickCount hashNo, modBreaks) diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs index a05e3597be..04236d54b9 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -52,7 +52,6 @@ import GHC.HsToCore.Pmc.Solver import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) import GHC.Driver.Session -import GHC.Driver.Env import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc @@ -60,12 +59,12 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Var (EvVar) -import GHC.Tc.Types import GHC.Tc.Utils.TcType (evVarPred) +import GHC.Tc.Utils.Monad (updTopFlags) import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr) import GHC.HsToCore.Monad import GHC.Data.Bag -import GHC.Data.IOEnv (updEnv, unsafeInterleaveM) +import GHC.Data.IOEnv (unsafeInterleaveM) import GHC.Data.OrdList import GHC.Utils.Monad (mapMaybeM) @@ -95,10 +94,7 @@ getLdiNablas = do -- is one concern, but also a lack of properly set up long-distance information -- might trigger warnings that we normally wouldn't emit. noCheckDs :: DsM a -> DsM a -noCheckDs k = do - dflags <- getDynFlags - let dflags' = foldl' wopt_unset dflags allPmCheckWarnings - updEnv (\env -> env{env_top = (env_top env) {hsc_dflags = dflags'} }) k +noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings) -- | Check a pattern binding (let, where) for exhaustiveness. pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM () diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs index bf240317e4..0bafac4088 100644 --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -30,10 +30,9 @@ import GHC.HsToCore.Monad tracePm :: String -> SDoc -> DsM () tracePm herald doc = do - dflags <- getDynFlags - logger <- getLogger + logger <- getLogger printer <- mkPrintUnqualifiedDs - liftIO $ dumpIfSet_dyn_printer printer logger dflags + liftIO $ putDumpFileMaybe' logger printer Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) {-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities] diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index adcf62f8c5..05c5f6e192 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -270,10 +270,10 @@ newIfaceNames occs ; return [ mkInternalName uniq occ noSrcSpan | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } -trace_if :: Logger -> DynFlags -> SDoc -> IO () +trace_if :: Logger -> SDoc -> IO () {-# INLINE trace_if #-} -trace_if logger dflags doc = when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags doc +trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc -trace_hi_diffs :: Logger -> DynFlags -> SDoc -> IO () +trace_hi_diffs :: Logger -> SDoc -> IO () {-# INLINE trace_hi_diffs #-} -trace_hi_diffs logger dflags doc = when (dopt Opt_D_dump_hi_diffs dflags) $ putMsg logger dflags doc +trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 2afba91a6c..eac1ba3e9d 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -37,6 +37,8 @@ module GHC.Iface.Load ( import GHC.Prelude +import GHC.Platform.Profile + import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteMatches ) @@ -165,9 +167,8 @@ importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing) -- It's not a wired-in thing -- the caller caught that importDecl name = assert (not (isWiredInName name)) $ - do { dflags <- getDynFlags - ; logger <- getLogger - ; liftIO $ trace_if logger dflags nd_doc + do { logger <- getLogger + ; liftIO $ trace_if logger nd_doc -- Load the interface, which should populate the PTE ; mb_iface <- assertPpr (isExternalName name) (ppr name) $ @@ -241,9 +242,8 @@ checkWiredInTyCon tc = return () | otherwise = do { mod <- getModule - ; dflags <- getDynFlags ; logger <- getLogger - ; liftIO $ trace_if logger dflags (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) + ; liftIO $ trace_if logger (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) ; assert (isExternalName tc_name ) when (mod /= nameModule tc_name) (initIfaceTcRn (loadWiredInHomeIface tc_name)) @@ -442,15 +442,12 @@ loadInterface doc_str mod from | otherwise = do logger <- getLogger - dflags <- getDynFlags - withTimingSilent logger dflags (text "loading interface") (pure ()) $ do + withTimingSilent logger (text "loading interface") (pure ()) $ do { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv - ; dflags <- getDynFlags - ; logger <- getLogger - ; liftIO $ trace_if logger dflags (text "Considering whether to load" <+> ppr mod <+> ppr from) + ; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already ; hsc_env <- getTopEnv @@ -728,10 +725,9 @@ moduleFreeHolesPrecise doc_str mod | otherwise = case getModuleInstantiation mod of (imod, Just indef) -> do - dflags <- getDynFlags logger <- getLogger let insts = instUnitInsts (moduleUnit indef) - liftIO $ trace_if logger dflags (text "Considering whether to load" <+> ppr mod <+> + liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> text "to compute precise free module holes") (eps, hpt) <- getEpsAndHpt case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of @@ -863,7 +859,7 @@ findAndReadIface findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags - trace_if logger dflags (sep [hsep [text "Reading", + trace_if logger (sep [hsep [text "Reading", if hi_boot_file == IsBoot then text "[boot]" else Outputable.empty, @@ -902,7 +898,7 @@ findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str hi_boot_file iface fp return r err -> do - trace_if logger dflags (text "...not found") + trace_if logger (text "...not found") return $ Failed $ cannotFindInterface unit_state home_unit @@ -931,15 +927,15 @@ load_dynamic_too logger name_cache unit_state dflags wanted_mod is_boot iface fi | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> return () | otherwise -> - do trace_if logger dflags (text "Dynamic hash doesn't match") + do trace_if logger (text "Dynamic hash doesn't match") setDynamicTooFailed dflags Failed err -> - do trace_if logger dflags (text "Failed to load dynamic interface file:" $$ err) + do trace_if logger (text "Failed to load dynamic interface file:" $$ err) setDynamicTooFailed dflags read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath)) read_file logger name_cache unit_state dflags wanted_mod file_path = do - trace_if logger dflags (text "readIFace" <+> text file_path) + trace_if logger (text "readIFace" <+> text file_path) -- Figure out what is recorded in mi_module. If this is -- a fully definite interface, it'll match exactly, but @@ -958,11 +954,10 @@ read_file logger name_cache unit_state dflags wanted_mod file_path = do -- | Write interface file -writeIface :: Logger -> DynFlags -> FilePath -> ModIface -> IO () -writeIface logger dflags hi_file_path new_iface +writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO () +writeIface logger profile hi_file_path new_iface = do createDirectoryIfMissing True (takeDirectory hi_file_path) - let printer = TraceBinIFace (debugTraceMsg logger dflags 3) - profile = targetProfile dflags + let printer = TraceBinIFace (debugTraceMsg logger 3) writeBinIface profile printer hi_file_path new_iface -- | @readIface@ tries just the one file. @@ -1063,7 +1058,7 @@ For some background on this choice see trac #15269. showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO () showIface logger dflags unit_state name_cache filename = do let profile = targetProfile dflags - printer = putLogMsg logger dflags MCOutput noSrcSpan . withPprStyle defaultDumpStyle + printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. @@ -1076,7 +1071,7 @@ showIface logger dflags unit_state name_cache filename = do print_unqual = QueryQualify qualifyImportedNames neverQualifyModules neverQualifyPackages - putLogMsg logger dflags MCDump noSrcSpan + logMsg logger MCDump noSrcSpan $ withPprStyle (mkDumpStyle print_unqual) $ pprModIface unit_state iface diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 86ff68272d..4af7ddbf05 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -150,7 +150,7 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do -- Debug printing let unit_state = hsc_units hsc_env - dumpIfSet_dyn (hsc_logger hsc_env) (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText + putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface unit_state full_iface) return full_iface diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index ee47ec97ee..68ca5bfdbe 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -142,7 +142,7 @@ checkOldIface checkOldIface hsc_env mod_summary maybe_iface = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - showPass logger dflags $ + showPass logger $ "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary) ++ " (use -ddump-hi-diffs for more details)" @@ -161,7 +161,7 @@ check_old_iface hsc_env mod_summary maybe_iface getIface = case maybe_iface of Just _ -> do - trace_if logger dflags (text "We already have the old interface for" <+> + trace_if logger (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) return maybe_iface Nothing -> loadIface @@ -172,11 +172,11 @@ check_old_iface hsc_env mod_summary maybe_iface read_result <- readIface dflags ncu (ms_mod mod_summary) iface_path case read_result of Failed err -> do - trace_if logger dflags (text "FYI: cannot read old interface file:" $$ nest 4 err) - trace_hi_diffs logger dflags (text "Old interface file was invalid:" $$ nest 4 err) + trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err) + trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err) return Nothing Succeeded iface -> do - trace_if logger dflags (text "Read the interface file" <+> text iface_path) + trace_if logger (text "Read the interface file" <+> text iface_path) return $ Just iface src_changed @@ -184,7 +184,7 @@ check_old_iface hsc_env mod_summary maybe_iface | otherwise = False in do when src_changed $ - liftIO $ trace_hi_diffs logger dflags (nest 4 $ text "Recompilation check turned off") + liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off") case src_changed of -- If the source has changed and we're in interactive mode, @@ -228,7 +228,7 @@ checkVersions :: HscEnv -> ModIface -- Old interface -> IfG (RecompileRequired, Maybe ModIface) checkVersions hsc_env mod_summary iface - = do { liftIO $ trace_hi_diffs logger dflags + = do { liftIO $ trace_hi_diffs logger (text "Considering whether compilation is required for" <+> ppr (mi_module iface) <> colon) @@ -248,7 +248,7 @@ checkVersions hsc_env mod_summary iface ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- liftIO $ checkMergedSignatures hsc_env mod_summary iface ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; recomp <- liftIO $ checkHsig logger home_unit dflags mod_summary iface + ; recomp <- liftIO $ checkHsig logger home_unit mod_summary iface ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- pure (checkHie dflags mod_summary) ; if recompileRequired recomp then return (recomp, Nothing) else do { @@ -355,13 +355,13 @@ pluginRecompileToRecompileRequired old_fp new_fp pr -- | Check if an hsig file needs recompilation because its -- implementing module has changed. -checkHsig :: Logger -> HomeUnit -> DynFlags -> ModSummary -> ModIface -> IO RecompileRequired -checkHsig logger home_unit dflags mod_summary iface = do +checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired +checkHsig logger home_unit mod_summary iface = do let outer_mod = ms_mod mod_summary inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod) massert (isHomeModule home_unit outer_mod) case inner_mod == mi_semantic_module iface of - True -> up_to_date logger dflags (text "implementing module unchanged") + True -> up_to_date logger (text "implementing module unchanged") False -> return (RecompBecause "implementing module changed") -- | Check if @.hie@ file is out of date or missing. @@ -381,47 +381,44 @@ checkHie dflags mod_summary = -- | Check the flags haven't changed checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired checkFlagHash hsc_env iface = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let old_hash = mi_flag_hash (mi_final_exts iface) new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally case old_hash == new_hash of - True -> up_to_date logger dflags (text "Module flags unchanged") - False -> out_of_date_hash logger dflags "flags changed" + True -> up_to_date logger (text "Module flags unchanged") + False -> out_of_date_hash logger "flags changed" (text " Module flags have changed") old_hash new_hash -- | Check the optimisation flags haven't changed checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired checkOptimHash hsc_env iface = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let old_hash = mi_opt_hash (mi_final_exts iface) new_hash <- fingerprintOptFlags (hsc_dflags hsc_env) putNameLiterally if | old_hash == new_hash - -> up_to_date logger dflags (text "Optimisation flags unchanged") + -> up_to_date logger (text "Optimisation flags unchanged") | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env) - -> up_to_date logger dflags (text "Optimisation flags changed; ignoring") + -> up_to_date logger (text "Optimisation flags changed; ignoring") | otherwise - -> out_of_date_hash logger dflags "Optimisation flags changed" + -> out_of_date_hash logger "Optimisation flags changed" (text " Optimisation flags have changed") old_hash new_hash -- | Check the HPC flags haven't changed checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired checkHpcHash hsc_env iface = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let old_hash = mi_hpc_hash (mi_final_exts iface) new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env) putNameLiterally if | old_hash == new_hash - -> up_to_date logger dflags (text "HPC flags unchanged") + -> up_to_date logger (text "HPC flags unchanged") | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env) - -> up_to_date logger dflags (text "HPC flags changed; ignoring") + -> up_to_date logger (text "HPC flags changed; ignoring") | otherwise - -> out_of_date_hash logger dflags "HPC flags changed" + -> out_of_date_hash logger "HPC flags changed" (text " HPC flags have changed") old_hash new_hash @@ -429,7 +426,6 @@ checkHpcHash hsc_env iface = do -- If the -unit-id flags change, this can change too. checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired checkMergedSignatures hsc_env mod_summary iface = do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let unit_state = hsc_units hsc_env let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] @@ -438,7 +434,7 @@ checkMergedSignatures hsc_env mod_summary iface = do Nothing -> [] Just r -> sort $ map (instModuleToModule unit_state) r if old_merged == new_merged - then up_to_date logger dflags (text "signatures to merge in unchanged" $$ ppr new_merged) + then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged) else return (RecompBecause "signatures to merge in changed") -- If the direct imports of this module are resolved to targets that @@ -487,7 +483,7 @@ checkDependencies hsc_env summary iface check_mods [] [] = return UpToDate check_mods [] (old:_) = do -- This case can happen when a module is change from HPT to package import - trace_hi_diffs logger dflags $ + trace_hi_diffs logger $ text "module no longer " <> quotes (ppr old) <> text "in dependencies" return (RecompBecause (moduleNameString old ++ " removed")) @@ -495,7 +491,7 @@ checkDependencies hsc_env summary iface | Just (old, olds') <- uncons olds , new == old = check_mods (dropWhile (== new) news) olds' | otherwise = do - trace_hi_diffs logger dflags $ + trace_hi_diffs logger $ text "imported module " <> quotes (ppr new) <> text " not among previous dependencies" return (RecompBecause (moduleNameString new ++ " added")) @@ -503,7 +499,7 @@ checkDependencies hsc_env summary iface check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired check_packages [] [] = return UpToDate check_packages [] (old:_) = do - trace_hi_diffs logger dflags $ + trace_hi_diffs logger $ text "package " <> quotes (ppr old) <> text "no longer in dependencies" return (RecompBecause (unitString old ++ " removed")) @@ -511,7 +507,7 @@ checkDependencies hsc_env summary iface | Just (old, olds') <- uncons olds , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds' | otherwise = do - trace_hi_diffs logger dflags $ + trace_hi_diffs logger $ text "imported package " <> quotes (ppr new) <> text " not among previous dependencies" return (RecompBecause ((fst new) ++ " package changed")) @@ -533,10 +529,9 @@ getFromModIface :: String -> Module -> (ModIface -> IO a) -> IfG (Maybe a) getFromModIface doc_msg mod getter = do -- Load the imported interface if possible - dflags <- getDynFlags logger <- getLogger let doc_str = sep [text doc_msg, ppr mod] - liftIO $ trace_hi_diffs logger dflags (text "Checking interface for module" <+> ppr mod) + liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod) mb_iface <- loadInterface doc_str mod ImportBySystem -- Load the interface, but don't complain on failure; @@ -544,7 +539,7 @@ getFromModIface doc_msg mod getter case mb_iface of Failed _ -> do - liftIO $ trace_hi_diffs logger dflags (sep [text "Couldn't load interface for module", ppr mod]) + liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod]) return Nothing -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain: it might @@ -559,29 +554,26 @@ checkModUsage :: Unit -> Usage -> IfG RecompileRequired checkModUsage _this_pkg UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do - dflags <- getDynFlags logger <- getLogger needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed" - checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) -- We only track the ABI hash of package modules, rather than -- individual entity usages, so if the ABI hash changes we must -- recompile. This is safe but may entail more recompilation when -- a dependent package has changed. checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do - dflags <- getDynFlags logger <- getLogger needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed (raw)" - checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) checkModUsage this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do let mod = mkModule this_pkg mod_name - dflags <- getDynFlags logger <- getLogger needInterface mod $ \iface -> do let reason = moduleNameString (moduleName mod) ++ " changed (interface)" - checkIfaceFingerprint logger dflags reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) + checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) checkModUsage this_pkg UsageHomeModule{ usg_mod_name = mod_name, @@ -590,7 +582,6 @@ checkModUsage this_pkg UsageHomeModule{ usg_entities = old_decl_hash } = do let mod = mkModule this_pkg mod_name - dflags <- getDynFlags logger <- getLogger needInterface mod $ \iface -> do let @@ -602,20 +593,20 @@ checkModUsage this_pkg UsageHomeModule{ liftIO $ do -- CHECK MODULE - recompile <- checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash + recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash if not (recompileRequired recompile) then return UpToDate else -- CHECK EXPORT LIST - checkMaybeHash logger dflags reason maybe_old_export_hash new_export_hash + checkMaybeHash logger reason maybe_old_export_hash new_export_hash (text " Export list changed") $ do -- CHECK ITEMS ONE BY ONE - recompile <- checkList [ checkEntityUsage logger dflags reason new_decl_hash u + recompile <- checkList [ checkEntityUsage logger reason new_decl_hash u | u <- old_decl_hash] if recompileRequired recompile then return recompile -- This one failed, so just bail out now - else up_to_date logger dflags (text " Great! The bits I use are up to date") + else up_to_date logger (text " Great! The bits I use are up to date") checkModUsage _this_pkg UsageFile{ usg_file_path = file, @@ -637,78 +628,74 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file, ------------------------ checkModuleFingerprint :: Logger - -> DynFlags -> String -> Fingerprint -> Fingerprint -> IO RecompileRequired -checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash +checkModuleFingerprint logger reason old_mod_hash new_mod_hash | new_mod_hash == old_mod_hash - = up_to_date logger dflags (text "Module fingerprint unchanged") + = up_to_date logger (text "Module fingerprint unchanged") | otherwise - = out_of_date_hash logger dflags reason (text " Module fingerprint has changed") + = out_of_date_hash logger reason (text " Module fingerprint has changed") old_mod_hash new_mod_hash checkIfaceFingerprint :: Logger - -> DynFlags -> String -> Fingerprint -> Fingerprint -> IO RecompileRequired -checkIfaceFingerprint logger dflags reason old_mod_hash new_mod_hash +checkIfaceFingerprint logger reason old_mod_hash new_mod_hash | new_mod_hash == old_mod_hash - = up_to_date logger dflags (text "Iface fingerprint unchanged") + = up_to_date logger (text "Iface fingerprint unchanged") | otherwise - = out_of_date_hash logger dflags reason (text " Iface fingerprint has changed") + = out_of_date_hash logger reason (text " Iface fingerprint has changed") old_mod_hash new_mod_hash ------------------------ checkMaybeHash :: Logger - -> DynFlags -> String -> Maybe Fingerprint -> Fingerprint -> SDoc -> IO RecompileRequired -> IO RecompileRequired -checkMaybeHash logger dflags reason maybe_old_hash new_hash doc continue +checkMaybeHash logger reason maybe_old_hash new_hash doc continue | Just hash <- maybe_old_hash, hash /= new_hash - = out_of_date_hash logger dflags reason doc hash new_hash + = out_of_date_hash logger reason doc hash new_hash | otherwise = continue ------------------------ checkEntityUsage :: Logger - -> DynFlags -> String -> (OccName -> Maybe (OccName, Fingerprint)) -> (OccName, Fingerprint) -> IO RecompileRequired -checkEntityUsage logger dflags reason new_hash (name,old_hash) = do +checkEntityUsage logger reason new_hash (name,old_hash) = do case new_hash name of -- We used it before, but it ain't there now - Nothing -> out_of_date logger dflags reason (sep [text "No longer exported:", ppr name]) + Nothing -> out_of_date logger reason (sep [text "No longer exported:", ppr name]) -- It's there, but is it up to date? Just (_, new_hash) | new_hash == old_hash - -> do trace_hi_diffs logger dflags (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) + -> do trace_hi_diffs logger (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) return UpToDate | otherwise - -> out_of_date_hash logger dflags reason (text " Out of date:" <+> ppr name) old_hash new_hash + -> out_of_date_hash logger reason (text " Out of date:" <+> ppr name) old_hash new_hash -up_to_date :: Logger -> DynFlags -> SDoc -> IO RecompileRequired -up_to_date logger dflags msg = trace_hi_diffs logger dflags msg >> return UpToDate +up_to_date :: Logger -> SDoc -> IO RecompileRequired +up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate -out_of_date :: Logger -> DynFlags -> String -> SDoc -> IO RecompileRequired -out_of_date logger dflags reason msg = trace_hi_diffs logger dflags msg >> return (RecompBecause reason) +out_of_date :: Logger -> String -> SDoc -> IO RecompileRequired +out_of_date logger reason msg = trace_hi_diffs logger msg >> return (RecompBecause reason) -out_of_date_hash :: Logger -> DynFlags -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired -out_of_date_hash logger dflags reason msg old_hash new_hash - = out_of_date logger dflags reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) +out_of_date_hash :: Logger -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired +out_of_date_hash logger reason msg old_hash new_hash + = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) ---------------------- checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 83a1ea8346..101d470bdc 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -144,8 +144,8 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small -- We don't look at the bindings at all -- there aren't any -- for hs-boot files -mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails -mkBootModDetailsTc hsc_env +mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc logger TcGblEnv{ tcg_exports = exports, tcg_type_env = type_env, -- just for the Ids tcg_tcs = tcs, @@ -157,7 +157,7 @@ mkBootModDetailsTc hsc_env } = -- This timing isn't terribly useful since the result isn't forced, but -- the message is useful to locating oneself in the compilation process. - Err.withTiming logger dflags + Err.withTiming logger (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $ return (ModDetails { md_types = type_env' @@ -169,9 +169,6 @@ mkBootModDetailsTc hsc_env , md_complete_matches = complete_matches }) where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - -- Find the LocalIds in the type env that are exported -- Make them into GlobalIds, and tidy their types -- @@ -365,7 +362,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_modBreaks = modBreaks }) - = Err.withTiming logger dflags + = Err.withTiming logger (text "CoreTidy"<+>brackets (ppr mod)) (const ()) $ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags @@ -438,15 +435,15 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- If the endPass didn't print the rules, but ddump-rules is -- on, print now - ; unless (dopt Opt_D_dump_simpl dflags) $ - Logger.dumpIfSet_dyn logger dflags Opt_D_dump_rules + ; unless (logHasDumpFlag logger Opt_D_dump_simpl) $ + Logger.putDumpFileMaybe logger Opt_D_dump_rules (showSDoc dflags (ppr CoreTidy <+> text "rules")) FormatText (pprRulesForUser tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds - ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_core_stats "Core Stats" + ; Logger.putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats" FormatText (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index de65e43ccd..b5f3618003 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1221,7 +1221,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd Nothing -> return () Just errs -> do logger <- getLogger - liftIO $ displayLintResults logger dflags False doc + liftIO $ displayLintResults logger False doc (pprCoreExpr rhs') (emptyBag, errs) } ; return (bndrs', args', rhs') } @@ -1763,7 +1763,7 @@ tcPragExpr is_compulsory toplvl name expr case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of Nothing -> return () Just errs -> liftIO $ - displayLintResults logger dflags False doc + displayLintResults logger False doc (pprCoreExpr core_expr') (emptyBag, errs) return core_expr' where diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs index 15fe7b69fd..81fa062805 100644 --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -90,7 +90,7 @@ mkExtraObj logger tmpfs dflags unit_state extn xs mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ - logInfo logger dflags $ withPprStyle defaultUserStyle + logInfo logger $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") @@ -238,11 +238,11 @@ checkLinkInfo logger dflags unit_env pkg_deps exe_file | otherwise = do link_info <- getLinkInfo dflags unit_env pkg_deps - debugTraceMsg logger dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString logger dflags exe_file + debugTraceMsg logger 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString logger exe_file ghcLinkInfoSectionName ghcLinkInfoNoteName let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg logger dflags 3 $ case m_exe_link_info of + debugTraceMsg logger 3 $ case m_exe_link_info of Nothing -> text "Exe link info: Not found" Just s | sameLinkInfo -> text ("Exe link info is the same") diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 8535bc83f2..97cfac3a7e 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -351,16 +351,16 @@ loadCmdLineLibs' interp hsc_env pls = lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base - maybePutStrLn logger dflags "Search directories (user):" - maybePutStr logger dflags (unlines $ map (" "++) lib_paths_env) - maybePutStrLn logger dflags "Search directories (gcc):" - maybePutStr logger dflags (unlines $ map (" "++) gcc_paths) + maybePutStrLn logger "Search directories (user):" + maybePutStr logger (unlines $ map (" "++) lib_paths_env) + maybePutStrLn logger "Search directories (gcc):" + maybePutStr logger (unlines $ map (" "++) gcc_paths) libspecs <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls -- (d) Link .o files from the command-line - classified_ld_inputs <- mapM (classifyLdInput logger dflags) + classified_ld_inputs <- mapM (classifyLdInput logger platform) [ f | FileOption _ f <- cmdline_ld_inputs ] -- (e) Link any MacOS frameworks @@ -392,13 +392,13 @@ loadCmdLineLibs' interp hsc_env pls = pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls merged_specs - maybePutStr logger dflags "final link ... " + maybePutStr logger "final link ... " ok <- resolveObjs interp -- DLLs are loaded, reset the search paths mapM_ (removeLibrarySearchPath interp) $ reverse pathCache - if succeeded ok then maybePutStrLn logger dflags "done" + if succeeded ok then maybePutStrLn logger "done" else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") return pls1 @@ -441,16 +441,15 @@ package I want to link in eagerly". Would that be too complicated for users? -} -classifyLdInput :: Logger -> DynFlags -> FilePath -> IO (Maybe LibrarySpec) -classifyLdInput logger dflags f +classifyLdInput :: Logger -> Platform -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput logger platform f | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do - putLogMsg logger dflags MCInfo noSrcSpan + logMsg logger MCInfo noSrcSpan $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing - where platform = targetPlatform dflags preloadLib :: Interp @@ -461,22 +460,22 @@ preloadLib -> LibrarySpec -> IO LoaderState preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do - maybePutStr logger dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + maybePutStr logger ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of Objects static_ishs -> do (b, pls1) <- preload_statics lib_paths static_ishs - maybePutStrLn logger dflags (if b then "done" else "not found") + maybePutStrLn logger (if b then "done" else "not found") return pls1 Archive static_ish -> do b <- preload_static_archive lib_paths static_ish - maybePutStrLn logger dflags (if b then "done" else "not found") + maybePutStrLn logger (if b then "done" else "not found") return pls DLL dll_unadorned -> do maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) case maybe_errstr of - Nothing -> maybePutStrLn logger dflags "done" + Nothing -> maybePutStrLn logger "done" Just mm | platformOS platform /= OSDarwin -> preloadFailed mm lib_paths lib_spec Just mm | otherwise -> do @@ -486,14 +485,14 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do let libfile = ("lib" ++ dll_unadorned) <.> "so" err2 <- loadDLL interp libfile case err2 of - Nothing -> maybePutStrLn logger dflags "done" + Nothing -> maybePutStrLn logger "done" Just _ -> preloadFailed mm lib_paths lib_spec return pls DLLPath dll_path -> do do maybe_errstr <- loadDLL interp dll_path case maybe_errstr of - Nothing -> maybePutStrLn logger dflags "done" + Nothing -> maybePutStrLn logger "done" Just mm -> preloadFailed mm lib_paths lib_spec return pls @@ -501,7 +500,7 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do if platformUsesFrameworks (targetPlatform dflags) then do maybe_errstr <- loadFramework interp framework_paths framework case maybe_errstr of - Nothing -> maybePutStrLn logger dflags "done" + Nothing -> maybePutStrLn logger "done" Just mm -> preloadFailed mm framework_paths lib_spec return pls else throwGhcExceptionIO (ProgramError "preloadLib Framework") @@ -514,7 +513,7 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do preloadFailed :: String -> [String] -> LibrarySpec -> IO () preloadFailed sys_errmsg paths spec - = do maybePutStr logger dflags "failed.\n" + = do maybePutStr logger "failed.\n" throwGhcExceptionIO $ CmdLineError ( "user specified .o/.so/.DLL could not be loaded (" @@ -1128,11 +1127,10 @@ unload interp hsc_env linkables pls1 <- unload_wkr interp linkables pls return (pls1, pls1) - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - debugTraceMsg logger dflags 3 $ + debugTraceMsg logger 3 $ text "unload: retaining objs" <+> ppr (objs_loaded new_pls) - debugTraceMsg logger dflags 3 $ + debugTraceMsg logger 3 $ text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) return () @@ -1325,7 +1323,7 @@ loadPackage interp hsc_env pkg all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths pathCache <- mapM (addLibrarySearchPath interp) all_paths_env - maybePutSDoc logger dflags + maybePutSDoc logger (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") -- See comments with partOfGHCi @@ -1345,7 +1343,7 @@ loadPackage interp hsc_env pkg mapM_ (loadObj interp) objs mapM_ (loadArchive interp) archs - maybePutStr logger dflags "linking ... " + maybePutStr logger "linking ... " ok <- resolveObjs interp -- DLLs are loaded, reset the search paths @@ -1356,7 +1354,7 @@ loadPackage interp hsc_env pkg if succeeded ok then do - maybePutStrLn logger dflags "done." + maybePutStrLn logger "done." return (hs_classifieds, extra_classifieds) else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" @@ -1419,7 +1417,7 @@ load_dyn interp hsc_env crash_early dll = do then cmdLineErrorIO err else when (wopt Opt_WarnMissedExtraSharedLib dflags) - $ putLogMsg logger dflags + $ logMsg logger (mkMCDiagnostic dflags $ WarningWithFlag Opt_WarnMissedExtraSharedLib) noSrcSpan $ withPprStyle defaultUserStyle (note err) where @@ -1580,10 +1578,11 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib , not loading_dynamic_hs_libs , interpreterProfiled interp = do - warningMsg logger dflags - (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ + let diag = mkMCDiagnostic dflags WarningWithoutFlag + logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $ + text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ text " \tTrying dynamic library instead. If this fails try to rebuild" <+> - text "libraries with profiling support.") + text "libraries with profiling support." return (DLL lib) | otherwise = return (DLL lib) infixr `orElse` @@ -1714,16 +1713,16 @@ addEnvPaths name list ********************************************************************* -} -maybePutSDoc :: Logger -> DynFlags -> SDoc -> IO () -maybePutSDoc logger dflags s - = when (verbosity dflags > 1) $ - putLogMsg logger dflags +maybePutSDoc :: Logger -> SDoc -> IO () +maybePutSDoc logger s + = when (logVerbAtLeast logger 2) $ + logMsg logger MCInteractive noSrcSpan $ withPprStyle defaultUserStyle s -maybePutStr :: Logger -> DynFlags -> String -> IO () -maybePutStr logger dflags s = maybePutSDoc logger dflags (text s) +maybePutStr :: Logger -> String -> IO () +maybePutStr logger s = maybePutSDoc logger (text s) -maybePutStrLn :: Logger -> DynFlags -> String -> IO () -maybePutStrLn logger dflags s = maybePutSDoc logger dflags (text s <> text "\n") +maybePutStrLn :: Logger -> String -> IO () +maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n") diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index cd4c0c8295..0249acb769 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -26,7 +26,7 @@ import GHC.Prelude import GHC.Platform import GHC.Driver.Session -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions! import GHC.Parser.Errors.Types diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index ab17333c0e..5cba042415 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -41,7 +41,7 @@ import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy ) import GHC.Driver.Session import GHC.Data.FastString -import GHC.Utils.Logger ( dumpIfSet_dyn_printer, DumpFormat (..), getLogger ) +import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName @@ -817,10 +817,8 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) when is_decl $ do -- Raw material for -dth-dec-file - dflags <- getDynFlags logger <- getLogger - liftIO $ dumpIfSet_dyn_printer alwaysQualify logger dflags Opt_D_th_dec_file - "" FormatHaskell (spliceCodeDoc loc) + liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc) where -- `-ddump-splices` spliceDebugDoc :: SrcSpan -> SDoc diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 99f189e079..04709b38cf 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -97,9 +97,8 @@ pprintClosureCommand bindThings force str = do printSDocs :: GhcMonad m => [SDoc] -> m () printSDocs sdocs = do logger <- getLogger - dflags <- getDynFlags unqual <- GHC.getPrintUnqual - liftIO $ printOutputForUser logger dflags unqual $ vcat sdocs + liftIO $ printOutputForUser logger unqual $ vcat sdocs -- Do the obtainTerm--bindSuspensions-computeSubstitution dance go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) @@ -118,10 +117,9 @@ pprintClosureCommand bindThings force str = do hsc_env <- getSession case (improveRTTIType hsc_env id_ty' reconstructed_type) of Nothing -> return (subst, term') - Just subst' -> do { dflags <- GHC.getSessionDynFlags - ; logger <- getLogger + Just subst' -> do { logger <- getLogger ; liftIO $ - dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI" + putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" FormatText (fsep $ [text "RTTI Improvement for", ppr id, text "old substitution:" , ppr subst, diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 7f6bf2009a..1c3c72d228 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -578,7 +578,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do mb_hValues <- mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets when (any isNothing mb_hValues) $ - debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) 1 $ + debugTraceMsg (hsc_logger hsc_env) 1 $ text "Warning: _result has been evaluated, some bindings have been lost" us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time @@ -668,9 +668,8 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do warnPprTrace True (text (":print failed to calculate the " ++ "improvement for a type")) hsc_env Just subst -> do - let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env - dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI" + putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" FormatText (fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]) diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 3eef85f715..f64236350c 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -192,11 +192,10 @@ getValueSafely hsc_env mnwib val_name expected_type = do case mb_hval of Nothing -> return Nothing Just hval -> do - value <- lessUnsafeCoerce logger dflags "getValueSafely" hval + value <- lessUnsafeCoerce logger "getValueSafely" hval return (Just value) where interp = hscInterp hsc_env - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env @@ -232,12 +231,12 @@ getHValueSafely interp hsc_env mnwib val_name expected_type = do -- -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened -- if it /does/ segfault -lessUnsafeCoerce :: Logger -> DynFlags -> String -> a -> IO b -lessUnsafeCoerce logger dflags context what = do - debugTraceMsg logger dflags 3 $ +lessUnsafeCoerce :: Logger -> String -> a -> IO b +lessUnsafeCoerce logger context what = do + debugTraceMsg logger 3 $ (text "Coercing a value in") <+> (text context) <> (text "...") output <- evaluate (unsafeCoerce what) - debugTraceMsg logger dflags 3 (text "Successfully evaluated coercion") + debugTraceMsg logger 3 (text "Successfully evaluated coercion") return output diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index abdc5e8328..5b15f92167 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -79,7 +79,7 @@ lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds Nothing -> return () Just msg -> do - putLogMsg logger dflags Err.MCDump noSrcSpan + logMsg logger Err.MCDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunnit <+> text "***", @@ -87,7 +87,7 @@ lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds text "*** Offending Program ***", pprGenStgTopBindings opts binds, text "*** End of Offense ***"]) - Err.ghcExit logger dflags 1 + Err.ghcExit logger 1 where opts = initStgPprOpts dflags -- Bring all top-level binds into scope because CoreToStg does not generate diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index 43f33d7fd8..5754b23baa 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -54,7 +54,7 @@ stg2stg :: Logger -> IO [StgTopBinding] -- output program stg2stg logger dflags ictxt this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds - ; showPass logger dflags "Stg2Stg" + ; showPass logger "Stg2Stg" -- Do the main business! ; binds' <- runStgM 'g' $ foldM do_stg_pass binds (getStgToDo dflags) @@ -107,11 +107,11 @@ stg2stg logger dflags ictxt this_mod binds opts = initStgPprOpts dflags dump_when flag header binds - = dumpIfSet_dyn logger dflags flag header FormatSTG (pprStgTopBindings opts binds) + = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings opts binds) end_pass what binds2 = liftIO $ do -- report verbosely, if required - dumpIfSet_dyn logger dflags Opt_D_verbose_stg2stg what + putDumpFileMaybe logger Opt_D_verbose_stg2stg what FormatSTG (vcat (map (pprStgTopBinding opts) binds2)) stg_linter False what binds2 return binds2 diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index f7bb270e16..a67c42bf91 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -104,7 +104,7 @@ byteCodeGen :: HscEnv -> Maybe ModBreaks -> IO CompiledByteCode byteCodeGen hsc_env this_mod binds tycs mb_modBreaks - = withTiming logger dflags + = withTiming logger (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do -- Split top-level binds into strings and others. @@ -129,7 +129,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks when (notNull ffis) (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?") - dumpIfSet_dyn logger dflags Opt_D_dump_BCOs + putDumpFileMaybe logger Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (vcat (intersperse (char ' ') (map ppr proto_bcos))) @@ -148,8 +148,8 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks return cbc - where dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env + where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env interp = hscInterp hsc_env profile = targetProfile dflags @@ -186,7 +186,7 @@ stgExprToBCOs :: HscEnv -> StgRhs -> IO UnlinkedBCO stgExprToBCOs hsc_env this_mod expr_ty expr - = withTiming logger dflags + = withTiming logger (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do @@ -205,12 +205,12 @@ stgExprToBCOs hsc_env this_mod expr_ty expr when (notNull mallocd) (panic "GHC.StgToByteCode.stgExprToBCOs: missing final emitBc?") - dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode + putDumpFileMaybe logger Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (ppr proto_bco) assembleOneBCO interp profile proto_bco - where dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env + where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env profile = targetProfile dflags interp = hscInterp hsc_env -- we need an otherwise unused Id for bytecode generation diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index f8fe4f71d8..5373e3d07f 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -98,7 +98,7 @@ codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s) ; let cg :: FCode a -> Stream IO CmmGroup a cg fcode = do - (a, cmm) <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do + (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do CodeGenState ts st <- readIORef cgref let (a,st') = runC dflags this_mod st (getCmm fcode) diff --git a/compiler/GHC/SysTools/Elf.hs b/compiler/GHC/SysTools/Elf.hs index 7dbfea9d2b..da517e25dd 100644 --- a/compiler/GHC/SysTools/Elf.hs +++ b/compiler/GHC/SysTools/Elf.hs @@ -18,7 +18,6 @@ import GHC.Prelude import GHC.Utils.Asm import GHC.Utils.Exception -import GHC.Driver.Session import GHC.Platform import GHC.Utils.Error import GHC.Data.Maybe (MaybeT(..),runMaybeT) @@ -142,9 +141,9 @@ data ElfHeader = ElfHeader -- | Read the ELF header -readElfHeader :: Logger -> DynFlags -> ByteString -> IO (Maybe ElfHeader) -readElfHeader logger dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfHeader :: Logger -> ByteString -> IO (Maybe ElfHeader) +readElfHeader logger bs = runGetOrThrow getHeader bs `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF header") return Nothing where @@ -196,13 +195,12 @@ data SectionTable = SectionTable -- | Read the ELF section table readElfSectionTable :: Logger - -> DynFlags -> ElfHeader -> ByteString -> IO (Maybe SectionTable) -readElfSectionTable logger dflags hdr bs = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfSectionTable logger hdr bs = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF section table") return Nothing where @@ -248,15 +246,14 @@ data Section = Section -- | Read a ELF section readElfSectionByIndex :: Logger - -> DynFlags -> ElfHeader -> SectionTable -> Word64 -> ByteString -> IO (Maybe Section) -readElfSectionByIndex logger dflags hdr secTable i bs = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfSectionByIndex logger hdr secTable i bs = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF section") return Nothing where @@ -293,13 +290,12 @@ readElfSectionByIndex logger dflags hdr secTable i bs = action `catchIO` \_ -> d -- -- We do not perform any check on the section type. findSectionFromName :: Logger - -> DynFlags -> ElfHeader -> SectionTable -> String -> ByteString -> IO (Maybe ByteString) -findSectionFromName logger dflags hdr secTable name bs = +findSectionFromName logger hdr secTable name bs = rec [0..sectionEntryCount secTable - 1] where -- convert the required section name into a ByteString to perform @@ -310,7 +306,7 @@ findSectionFromName logger dflags hdr secTable name bs = -- the matching one, if any rec [] = return Nothing rec (x:xs) = do - me <- readElfSectionByIndex logger dflags hdr secTable x bs + me <- readElfSectionByIndex logger hdr secTable x bs case me of Just e | entryName e == name' -> return (Just (entryBS e)) _ -> rec xs @@ -321,20 +317,19 @@ findSectionFromName logger dflags hdr secTable name bs = -- If the section isn't found or if there is any parsing error, we return -- Nothing readElfSectionByName :: Logger - -> DynFlags -> ByteString -> String -> IO (Maybe LBS.ByteString) -readElfSectionByName logger dflags bs name = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfSectionByName logger bs name = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF section \"" ++ name ++ "\"") return Nothing where action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader logger dflags bs - secTable <- MaybeT $ readElfSectionTable logger dflags hdr bs - MaybeT $ findSectionFromName logger dflags hdr secTable name bs + hdr <- MaybeT $ readElfHeader logger bs + secTable <- MaybeT $ readElfSectionTable logger hdr bs + MaybeT $ findSectionFromName logger hdr secTable name bs ------------------ -- NOTE SECTIONS @@ -345,14 +340,13 @@ readElfSectionByName logger dflags bs name = action `catchIO` \_ -> do -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned readElfNoteBS :: Logger - -> DynFlags -> ByteString -> String -> String -> IO (Maybe LBS.ByteString) -readElfNoteBS logger dflags bs sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfNoteBS logger bs sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF note \"" ++ noteId ++ "\" in section \"" ++ sectionName ++ "\"") return Nothing @@ -386,8 +380,8 @@ readElfNoteBS logger dflags bs sectionName noteId = action `catchIO` \_ -> do action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader logger dflags bs - sec <- MaybeT $ readElfSectionByName logger dflags bs sectionName + hdr <- MaybeT $ readElfHeader logger bs + sec <- MaybeT $ readElfSectionByName logger bs sectionName MaybeT $ runGetOrThrow (findNote hdr) sec -- | read a Note as a String @@ -395,21 +389,20 @@ readElfNoteBS logger dflags bs sectionName noteId = action `catchIO` \_ -> do -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned readElfNoteAsString :: Logger - -> DynFlags -> FilePath -> String -> String -> IO (Maybe String) -readElfNoteAsString logger dflags path sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg logger dflags 3 $ +readElfNoteAsString logger path sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger 3 $ text ("Unable to read ELF note \"" ++ noteId ++ "\" in section \"" ++ sectionName ++ "\"") return Nothing where action = do bs <- LBS.readFile path - note <- readElfNoteBS logger dflags bs sectionName noteId + note <- readElfNoteBS logger bs sectionName noteId return (fmap B8.unpack note) diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs index 733c2eaade..12be61ea0b 100644 --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -195,10 +195,10 @@ getLinkerInfo' logger dflags = do parseLinkerInfo (lines stdo) (lines stde) exitc ) (\err -> do - debugTraceMsg logger dflags 2 + debugTraceMsg logger 2 (text "Error (figuring out linker information):" <+> text (show err)) - errorMsg logger dflags $ hang (text "Warning:") 9 $ + errorMsg logger $ hang (text "Warning:") 9 $ text "Couldn't figure out linker information!" $$ text "Make sure you're using GNU ld, GNU gold" <+> text "or the built in OS X linker, etc." @@ -213,7 +213,7 @@ getCompilerInfo logger dflags = do Just v -> return v Nothing -> do let pgm = pgm_c dflags - v <- getCompilerInfo' logger dflags pgm + v <- getCompilerInfo' logger pgm writeIORef (rtccInfo dflags) (Just v) return v @@ -225,13 +225,13 @@ getAssemblerInfo logger dflags = do Just v -> return v Nothing -> do let (pgm, _) = pgm_a dflags - v <- getCompilerInfo' logger dflags pgm + v <- getCompilerInfo' logger pgm writeIORef (rtasmInfo dflags) (Just v) return v -- See Note [Run-time linker info]. -getCompilerInfo' :: Logger -> DynFlags -> String -> IO CompilerInfo -getCompilerInfo' logger dflags pgm = do +getCompilerInfo' :: Logger -> String -> IO CompilerInfo +getCompilerInfo' logger pgm = do let -- Try to grab the info from the process output. parseCompilerInfo _stdo stde _exitc -- Regular GCC @@ -264,10 +264,10 @@ getCompilerInfo' logger dflags pgm = do parseCompilerInfo (lines stdo) (lines stde) exitc ) (\err -> do - debugTraceMsg logger dflags 2 + debugTraceMsg logger 2 (text "Error (figuring out C compiler information):" <+> text (show err)) - errorMsg logger dflags $ hang (text "Warning:") 9 $ + errorMsg logger $ hang (text "Warning:") 9 $ text "Couldn't figure out C compiler information!" $$ text "Make sure you're using GNU gcc, or clang" return UnknownCC diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index 7328a1c57f..6cb322363d 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -131,7 +131,6 @@ getGccEnv opts = -- Running an external program runSomething :: Logger - -> DynFlags -> String -- For -v message -> String -- Command name (possibly a full path) -- assumed already dos-ified @@ -139,8 +138,8 @@ runSomething :: Logger -- runSomething will dos-ify them -> IO () -runSomething logger dflags phase_name pgm args = - runSomethingFiltered logger dflags id phase_name pgm args Nothing Nothing +runSomething logger phase_name pgm args = + runSomethingFiltered logger id phase_name pgm args Nothing Nothing -- | Run a command, placing the arguments in an external response file. -- @@ -162,10 +161,10 @@ runSomethingResponseFile -> Maybe [(String,String)] -> IO () runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env = - runSomethingWith logger dflags phase_name pgm args $ \real_args -> do + runSomethingWith logger phase_name pgm args $ \real_args -> do fp <- getResponseFile real_args let args = ['@':fp] - r <- builderMainLoop logger dflags filter_fn pgm args Nothing mb_env + r <- builderMainLoop logger filter_fn pgm args Nothing mb_env return (r,()) where getResponseFile args = do @@ -205,23 +204,23 @@ runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_en ] runSomethingFiltered - :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option] + :: Logger -> (String->String) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered logger dflags filter_fn phase_name pgm args mb_cwd mb_env = - runSomethingWith logger dflags phase_name pgm args $ \real_args -> do - r <- builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env +runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env = + runSomethingWith logger phase_name pgm args $ \real_args -> do + r <- builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env return (r,()) runSomethingWith - :: Logger -> DynFlags -> String -> String -> [Option] + :: Logger -> String -> String -> [Option] -> ([String] -> IO (ExitCode, a)) -> IO a -runSomethingWith logger dflags phase_name pgm args io = do +runSomethingWith logger phase_name pgm args io = do let real_args = filter notNull (map showOpt args) cmdLine = showCommandForUser pgm real_args - traceCmd logger dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args + traceCmd logger phase_name cmdLine $ handleProc pgm phase_name $ io real_args handleProc :: String -> String -> IO (ExitCode, r) -> IO r handleProc pgm phase_name proc = do @@ -241,10 +240,10 @@ handleProc pgm phase_name proc = do does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) -builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath +builderMainLoop :: Logger -> (String -> String) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> IO ExitCode -builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do +builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do chan <- newChan -- We use a mask here rather than a bracket because we want @@ -305,10 +304,10 @@ builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do msg <- readChan chan case msg of BuildMsg msg -> do - logInfo logger dflags $ withPprStyle defaultUserStyle msg + logInfo logger $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do - putLogMsg logger dflags errorDiagnostic (mkSrcSpan loc loc) + logMsg logger errorDiagnostic (mkSrcSpan loc loc) $ withPprStyle defaultUserStyle msg log_loop chan t EOF -> diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index ce286fe8ca..6fec3a8839 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -42,31 +42,31 @@ import System.Process -} runUnlit :: Logger -> DynFlags -> [Option] -> IO () -runUnlit logger dflags args = traceToolCommand logger dflags "unlit" $ do +runUnlit logger dflags args = traceToolCommand logger "unlit" $ do let prog = pgm_L dflags opts = getOpts dflags opt_L - runSomething logger dflags "Literate pre-processor" prog + runSomething logger "Literate pre-processor" prog (map Option opts ++ args) runCpp :: Logger -> DynFlags -> [Option] -> IO () -runCpp logger dflags args = traceToolCommand logger dflags "cpp" $ do +runCpp logger dflags args = traceToolCommand logger "cpp" $ do let (p,args0) = pgm_P dflags args1 = map Option (getOpts dflags opt_P) args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] mb_env <- getGccEnv args2 - runSomethingFiltered logger dflags id "C pre-processor" p + runSomethingFiltered logger id "C pre-processor" p (args0 ++ args1 ++ args2 ++ args) Nothing mb_env runPp :: Logger -> DynFlags -> [Option] -> IO () -runPp logger dflags args = traceToolCommand logger dflags "pp" $ do +runPp logger dflags args = traceToolCommand logger "pp" $ do let prog = pgm_F dflags opts = map Option (getOpts dflags opt_F) - runSomething logger dflags "Haskell pre-processor" prog (args ++ opts) + runSomething logger "Haskell pre-processor" prog (args ++ opts) -- | Run compiler of C-like languages and raw objects (such as gcc or clang). runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runCc mLanguage logger tmpfs dflags args = traceToolCommand logger dflags "cc" $ do +runCc mLanguage logger tmpfs dflags args = traceToolCommand logger "cc" $ do let p = pgm_c dflags args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 @@ -148,43 +148,43 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) -- | Run the linker with some arguments and return the output askLd :: Logger -> DynFlags -> [Option] -> IO String -askLd logger dflags args = traceToolCommand logger dflags "linker" $ do +askLd logger dflags args = traceToolCommand logger "linker" $ do let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - runSomethingWith logger dflags "gcc" p args2 $ \real_args -> + runSomethingWith logger "gcc" p args2 $ \real_args -> readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } runAs :: Logger -> DynFlags -> [Option] -> IO () -runAs logger dflags args = traceToolCommand logger dflags "as" $ do +runAs logger dflags args = traceToolCommand logger "as" $ do let (p,args0) = pgm_a dflags args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - runSomethingFiltered logger dflags id "Assembler" p args2 Nothing mb_env + runSomethingFiltered logger id "Assembler" p args2 Nothing mb_env -- | Run the LLVM Optimiser runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO () -runLlvmOpt logger dflags args = traceToolCommand logger dflags "opt" $ do +runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do let (p,args0) = pgm_lo dflags args1 = map Option (getOpts dflags opt_lo) -- We take care to pass -optlo flags (e.g. args0) last to ensure that the -- user can override flags passed by GHC. See #14821. - runSomething logger dflags "LLVM Optimiser" p (args1 ++ args ++ args0) + runSomething logger "LLVM Optimiser" p (args1 ++ args ++ args0) -- | Run the LLVM Compiler runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO () -runLlvmLlc logger dflags args = traceToolCommand logger dflags "llc" $ do +runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do let (p,args0) = pgm_lc dflags args1 = map Option (getOpts dflags opt_lc) - runSomething logger dflags "LLVM Compiler" p (args0 ++ args1 ++ args) + runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args) -- | Run the clang compiler (used as an assembler for the LLVM -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: Logger -> DynFlags -> [Option] -> IO () -runClang logger dflags args = traceToolCommand logger dflags "clang" $ do +runClang logger dflags args = traceToolCommand logger "clang" $ do let (clang,_) = pgm_lcc dflags -- be careful what options we call clang with -- see #5903 and #7617 for bugs caused by this. @@ -193,9 +193,9 @@ runClang logger dflags args = traceToolCommand logger dflags "clang" $ do args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 catchException - (runSomethingFiltered logger dflags id "Clang (Assembler)" clang args2 Nothing mb_env) + (runSomethingFiltered logger id "Clang (Assembler)" clang args2 Nothing mb_env) (\(err :: SomeException) -> do - errorMsg logger dflags $ + errorMsg logger $ text ("Error running clang! you need clang installed to use the" ++ " LLVM backend") $+$ text "(or GHC tried to execute clang incorrectly)" @@ -204,7 +204,7 @@ runClang logger dflags args = traceToolCommand logger dflags "clang" $ do -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) -figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do +figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) -- we grab the args even though they should be useless just in @@ -230,10 +230,10 @@ figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do return mb_ver ) (\err -> do - debugTraceMsg logger dflags 2 + debugTraceMsg logger 2 (text "Error (figuring out LLVM version):" <+> text (show err)) - errorMsg logger dflags $ vcat + errorMsg logger $ vcat [ text "Warning:", nest 9 $ text "Couldn't figure out LLVM version!" $$ text ("Make sure you have installed LLVM between " @@ -245,7 +245,7 @@ figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runLink logger tmpfs dflags args = traceToolCommand logger dflags "linker" $ do +runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do -- See Note [Run-time linker info] -- -- `-optl` args come at the end, so that later `-l` options @@ -310,7 +310,7 @@ ld: warning: symbol referencing errors -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () runMergeObjects logger tmpfs dflags args = - traceToolCommand logger dflags "merge-objects" $ do + traceToolCommand logger "merge-objects" $ do let (p,args0) = pgm_lm dflags optl_args = map Option (getOpts dflags opt_lm) args2 = args0 ++ args ++ optl_args @@ -321,40 +321,40 @@ runMergeObjects logger tmpfs dflags args = mb_env <- getGccEnv args2 runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env else do - runSomething logger dflags "Merge objects" p args2 + runSomething logger "Merge objects" p args2 runLibtool :: Logger -> DynFlags -> [Option] -> IO () -runLibtool logger dflags args = traceToolCommand logger dflags "libtool" $ do +runLibtool logger dflags args = traceToolCommand logger "libtool" $ do linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags let args1 = map Option (getOpts dflags opt_l) args2 = [Option "-static"] ++ args1 ++ args ++ linkargs libtool = pgm_libtool dflags mb_env <- getGccEnv args2 - runSomethingFiltered logger dflags id "Libtool" libtool args2 Nothing mb_env + runSomethingFiltered logger id "Libtool" libtool args2 Nothing mb_env runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr logger dflags cwd args = traceToolCommand logger dflags "ar" $ do +runAr logger dflags cwd args = traceToolCommand logger "ar" $ do let ar = pgm_ar dflags - runSomethingFiltered logger dflags id "Ar" ar args cwd Nothing + runSomethingFiltered logger id "Ar" ar args cwd Nothing askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String askOtool logger dflags mb_cwd args = do let otool = pgm_otool dflags - runSomethingWith logger dflags "otool" otool args $ \real_args -> + runSomethingWith logger "otool" otool args $ \real_args -> readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO () runInstallNameTool logger dflags args = do let tool = pgm_install_name_tool dflags - runSomethingFiltered logger dflags id "Install Name Tool" tool args Nothing Nothing + runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing runRanlib :: Logger -> DynFlags -> [Option] -> IO () -runRanlib logger dflags args = traceToolCommand logger dflags "ranlib" $ do +runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do let ranlib = pgm_ranlib dflags - runSomethingFiltered logger dflags id "Ranlib" ranlib args Nothing Nothing + runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing runWindres :: Logger -> DynFlags -> [Option] -> IO () -runWindres logger dflags args = traceToolCommand logger dflags "windres" $ do +runWindres logger dflags args = traceToolCommand logger "windres" $ do let cc = pgm_c dflags cc_args = map Option (sOpt_c (settings dflags)) windres = pgm_windres dflags @@ -374,11 +374,11 @@ runWindres logger dflags args = traceToolCommand logger dflags "windres" $ do : Option "--use-temp-file" : args mb_env <- getGccEnv cc_args - runSomethingFiltered logger dflags id "Windres" windres args' Nothing mb_env + runSomethingFiltered logger id "Windres" windres args' Nothing mb_env touch :: Logger -> DynFlags -> String -> String -> IO () -touch logger dflags purpose arg = traceToolCommand logger dflags "touch" $ - runSomething logger dflags purpose (pgm_T dflags) [FileOption "" arg] +touch logger dflags purpose arg = traceToolCommand logger "touch" $ + runSomething logger purpose (pgm_T dflags) [FileOption "" arg] -- * Tracing utility @@ -389,6 +389,5 @@ touch logger dflags purpose arg = traceToolCommand logger dflags "touch" $ -- -- For those events to show up in the eventlog, you need -- to run GHC with @-v2@ or @-ddump-timings@. -traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a -traceToolCommand logger dflags tool = withTiming logger - dflags (text $ "systool:" ++ tool) (const ()) +traceToolCommand :: Logger -> String -> IO a -> IO a +traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ()) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 8b7a437e79..58ce967690 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -235,7 +235,7 @@ tcDeriving deriv_infos deriv_decls ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds ; unless (isEmptyBag inst_info) $ - liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Derived instances" + liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances" FormatHaskell (ddump_deriving inst_info rn_binds famInsts)) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index d5e0f3255d..3fdc33c5a0 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -198,7 +198,7 @@ tcRnModule :: HscEnv tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} | RealSrcSpan real_loc _ <- loc - = withTiming logger dflags + = withTiming logger (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ @@ -211,7 +211,6 @@ tcRnModule hsc_env mod_sum save_rn_syntax where hsc_src = ms_hsc_src mod_sum - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env err_msg = mkPlainErrorMsgEnvelope loc $ @@ -2914,11 +2913,11 @@ rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) tcDump :: TcGblEnv -> TcRn () tcDump env - = do { dflags <- getDynFlags ; - unit_state <- hsc_units <$> getTopEnv ; + = do { unit_state <- hsc_units <$> getTopEnv ; + logger <- getLogger ; -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc) (dumpTcRn True Opt_D_dump_types "" FormatText (pprWithUnitState unit_state short_dump)) ; diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 9a4383a508..74c93c29ac 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -1289,9 +1289,9 @@ traceFireTcS ev doc csTraceTcM :: TcM SDoc -> TcM () -- Constraint-solver tracing, -ddump-cs-trace csTraceTcM mk_doc - = do { dflags <- getDynFlags - ; when ( dopt Opt_D_dump_cs_trace dflags - || dopt Opt_D_dump_tc_trace dflags ) + = do { logger <- getLogger + ; when ( logHasDumpFlag logger Opt_D_dump_cs_trace + || logHasDumpFlag logger Opt_D_dump_tc_trace) ( do { msg <- mk_doc ; TcM.dumpTcRn False Opt_D_dump_cs_trace diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 8177f145e6..bbaa4cee6d 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -2080,8 +2080,7 @@ mkDefMethBind :: DFunId -> Class -> Id -> Name -- See Note [Default methods in instances] for why we use -- visible type application here mkDefMethBind dfun_id clas sel_id dm_name - = do { dflags <- getDynFlags - ; logger <- getLogger + = do { logger <- getLogger ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag @@ -2098,7 +2097,7 @@ mkDefMethBind dfun_id clas sel_id dm_name bind = noLocA $ mkTopFunBind Generated fn $ [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] - ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body" + ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body" FormatHaskell (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 4af4aae1e1..a3b0068b3e 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -380,7 +380,7 @@ tcRnCheckUnit :: HscEnv -> Unit -> IO (Messages TcRnMessage, Maybe ()) tcRnCheckUnit hsc_env uid = - withTiming logger dflags + withTiming logger (text "Check unit id" <+> ppr uid) (const ()) $ initTc hsc_env @@ -401,13 +401,12 @@ tcRnCheckUnit hsc_env uid = tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = - withTiming logger dflags + withTiming logger (text "Signature merging" <+> brackets (ppr this_mod)) (const ()) $ initTc hsc_env HsigFile False this_mod real_loc $ mergeSignatures hpm orig_tcg_env iface where - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env this_mod = mi_module iface real_loc = tcg_top_loc orig_tcg_env @@ -939,12 +938,11 @@ tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = - withTiming logger dflags + withTiming logger (text "Signature instantiation"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature where - dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env exportOccs :: [AvailInfo] -> [OccName] diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 8b59f14fab..a40dc2c81e 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -21,6 +21,7 @@ module GHC.Tc.Utils.Monad( discardResult, getTopEnv, updTopEnv, getGblEnv, updGblEnv, setGblEnv, getLclEnv, updLclEnv, setLclEnv, + updTopFlags, getEnvs, setEnvs, xoptM, doptM, goptM, woptM, setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, @@ -266,10 +267,11 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ; !home_unit = hsc_home_unit hsc_env ; + !logger = hsc_logger hsc_env ; maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val - | dopt Opt_D_dump_rn_ast dflags = Just empty_val + | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val | gopt Opt_WriteHie dflags = Just empty_val @@ -499,32 +501,30 @@ setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = -- Command-line flags xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool -xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } +xoptM flag = xopt flag <$> getDynFlags doptM :: DumpFlag -> TcRnIf gbl lcl Bool -doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } +doptM flag = do + logger <- getLogger + return (logHasDumpFlag logger flag) goptM :: GeneralFlag -> TcRnIf gbl lcl Bool -goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) } +goptM flag = gopt flag <$> getDynFlags woptM :: WarningFlag -> TcRnIf gbl lcl Bool -woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } +woptM flag = wopt flag <$> getDynFlags setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag}) +setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag) unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetXOptM flag = - updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag}) +unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag) unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetGOptM flag = - updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag}) +unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag) unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetWOptM flag = - updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag}) +unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag) -- | Do it flag is true whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () @@ -554,12 +554,13 @@ unlessXOptM flag thing_inside = do b <- xoptM flag {-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities] getGhcMode :: TcRnIf gbl lcl GhcMode -getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } +getGhcMode = ghcMode <$> getDynFlags withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a -withoutDynamicNow = - updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) -> - top { hsc_dflags = dflags { dynamicNow = False} }) +withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False}) + +updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updTopFlags f = updTopEnv (hscUpdateFlags f) getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) getEpsVar = do @@ -777,21 +778,20 @@ dumpOptTcRn flag title fmt doc = -- dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpTcRn useUserStyle flag title fmt doc = do - dflags <- getDynFlags logger <- getLogger printer <- getPrintUnqualified real_doc <- wrapDocLoc doc let sty = if useUserStyle then mkUserStyle printer AllTheWay else mkDumpStyle printer - liftIO $ putDumpMsg logger dflags sty flag title fmt real_doc + liftIO $ logDumpFile logger sty flag title fmt real_doc -- | Add current location if -dppr-debug -- (otherwise the full location is usually way too much) wrapDocLoc :: SDoc -> TcRn SDoc wrapDocLoc doc = do - dflags <- getDynFlags - if hasPprDebug dflags + logger <- getLogger + if logHasDumpFlag logger Opt_D_ppr_debug then do loc <- getSrcSpanM return (mkLocMessage MCOutput loc doc) @@ -807,10 +807,9 @@ getPrintUnqualified -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () printForUserTcRn doc = do - dflags <- getDynFlags logger <- getLogger printer <- getPrintUnqualified - liftIO (printOutputForUser logger dflags printer doc) + liftIO (printOutputForUser logger printer doc) {- traceIf works in the TcRnIf monad, where no RdrEnv is @@ -826,9 +825,8 @@ traceIf = traceOptIf Opt_D_dump_if_trace traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () traceOptIf flag doc = whenDOptM flag $ do -- No RdrEnv available, so qualify everything - dflags <- getDynFlags logger <- getLogger - liftIO (putMsg logger dflags doc) + liftIO (putMsg logger doc) {-# INLINE traceOptIf #-} -- see Note [INLINE conditional tracing utilities] {- @@ -2134,9 +2132,8 @@ failIfM :: SDoc -> IfL a failIfM msg = do env <- getLclEnv let full_msg = (if_loc env <> colon) $$ nest 2 msg - dflags <- getDynFlags logger <- getLogger - liftIO (putLogMsg logger dflags MCFatal + liftIO (logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle full_msg) failM @@ -2166,11 +2163,10 @@ forkM_maybe doc thing_inside -- Otherwise we silently discard errors. Errors can legitimately -- happen when compiling interface signatures (see tcInterfaceSigs) whenDOptM Opt_D_dump_if_trace $ do - dflags <- getDynFlags logger <- getLogger let msg = hang (text "forkM failed:" <+> doc) 2 (text (show exn)) - liftIO $ putLogMsg logger dflags + liftIO $ logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index 99f01c492c..f3fb9d7645 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -577,14 +577,12 @@ initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatab initUnits logger dflags cached_dbs = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () - let ctx = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages - let printer = debugTraceMsg logger dflags -- printer for trace messages - (unit_state,dbs) <- withTiming logger dflags (text "initializing unit database") + (unit_state,dbs) <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs) + $ mkUnitState logger (initUnitConfig dflags cached_dbs) - dumpIfSet_dyn logger dflags Opt_D_dump_mod_map "Module Map" + putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) @@ -643,11 +641,11 @@ mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ = -- ----------------------------------------------------------------------------- -- Reading the unit database(s) -readUnitDatabases :: (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId] -readUnitDatabases printer cfg = do +readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger cfg = do conf_refs <- getUnitDbRefs cfg confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs - mapM (readUnitDatabase printer cfg) confs + mapM (readUnitDatabase logger cfg) confs getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] @@ -699,8 +697,8 @@ resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do if exist then return pkgconf else mzero resolveUnitDatabase _ (PkgDbPath name) = return $ Just name -readUnitDatabase :: (Int -> SDoc -> IO ()) -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId) -readUnitDatabase printer cfg conf_file = do +readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId) +readUnitDatabase logger cfg conf_file = do isdir <- doesDirectoryExist conf_file proto_pkg_configs <- @@ -736,21 +734,21 @@ readUnitDatabase printer cfg conf_file = do cache_exists <- doesFileExist filename if cache_exists then do - printer 2 $ text "Using binary package database:" <+> text filename + debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename readPackageDbForGhc filename else do -- If there is no package.cache file, we check if the database is not -- empty by inspecting if the directory contains any .conf file. If it -- does, something is wrong and we fail. Otherwise we assume that the -- database is empty. - printer 2 $ text "There is no package.cache in" + debugTraceMsg logger 2 $ text "There is no package.cache in" <+> text conf_dir <> text ", checking if the database is empty" db_empty <- all (not . isSuffixOf ".conf") <$> getDirectoryContents conf_dir if db_empty then do - printer 3 $ text "There are no .conf files in" + debugTraceMsg logger 3 $ text "There are no .conf files in" <+> text conf_dir <> text ", treating" <+> text "package database as empty" return [] @@ -775,7 +773,7 @@ readUnitDatabase printer cfg conf_file = do let conf_dir = conf_file <.> "d" direxists <- doesDirectoryExist conf_dir if direxists - then do printer 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) liftM Just (readDirStyleUnitInfo conf_dir) else return (Just []) -- ghc-pkg will create it when it's updated else return Nothing @@ -1030,7 +1028,7 @@ pprTrustFlag flag = case flag of type WiringMap = Map UnitId UnitId findWiredInUnits - :: (SDoc -> IO ()) -- debug trace + :: Logger -> UnitPrecedenceMap -> [UnitInfo] -- database -> VisibilityMap -- info on what units are visible @@ -1038,7 +1036,7 @@ findWiredInUnits -> IO ([UnitInfo], -- unit database updated for wired in WiringMap) -- map from unit id to wired identity -findWiredInUnits printer prec_map pkgs vis_map = do +findWiredInUnits logger prec_map pkgs vis_map = do -- Now we must find our wired-in units, and rename them to -- their canonical names (eg. base-1.0 ==> base), as described -- in Note [Wired-in units] in GHC.Unit.Module @@ -1076,14 +1074,14 @@ findWiredInUnits printer prec_map pkgs vis_map = do many -> pick (head (sortByPreference prec_map many)) where notfound = do - printer $ + debugTraceMsg logger 2 $ text "wired-in package " <> ftext (unitIdFS wired_pkg) <> text " not found." return Nothing pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo)) pick pkg = do - printer $ + debugTraceMsg logger 2 $ text "wired-in package " <> ftext (unitIdFS wired_pkg) <> text " mapped to " @@ -1203,20 +1201,20 @@ pprReason pref reason = case reason of pref <+> text "unusable due to shadowed dependencies:" $$ nest 2 (hsep (map ppr deps)) -reportCycles :: (SDoc -> IO ()) -> [SCC UnitInfo] -> IO () -reportCycles printer sccs = mapM_ report sccs +reportCycles :: Logger -> [SCC UnitInfo] -> IO () +reportCycles logger sccs = mapM_ report sccs where report (AcyclicSCC _) = return () report (CyclicSCC vs) = - printer $ + debugTraceMsg logger 2 $ text "these packages are involved in a cycle:" $$ nest 2 (hsep (map (ppr . unitId) vs)) -reportUnusable :: (SDoc -> IO ()) -> UnusableUnits -> IO () -reportUnusable printer pkgs = mapM_ report (Map.toList pkgs) +reportUnusable :: Logger -> UnusableUnits -> IO () +reportUnusable logger pkgs = mapM_ report (Map.toList pkgs) where report (ipid, (_, reason)) = - printer $ + debugTraceMsg logger 2 $ pprReason (text "package" <+> ppr ipid <+> text "is") reason @@ -1306,15 +1304,15 @@ type UnitPrecedenceMap = Map UnitId Int -- units with the same unit id in later databases override -- earlier ones. This does NOT check if the resulting database -- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: (SDoc -> IO ()) -> [UnitDatabase UnitId] +mergeDatabases :: Logger -> [UnitDatabase UnitId] -> IO (UnitInfoMap, UnitPrecedenceMap) -mergeDatabases printer = foldM merge (Map.empty, Map.empty) . zip [1..] +mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..] where merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do - printer $ + debugTraceMsg logger 2 $ text "loading package database" <+> text db_path forM_ (Set.toList override_set) $ \pkg -> - printer $ + debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> text "overrides a previously defined package" return (pkg_map', prec_map') @@ -1397,11 +1395,10 @@ validateDatabase cfg pkg_map1 = -- settings and populate the unit state. mkUnitState - :: SDocContext -- ^ SDocContext used to render exception messages - -> (Int -> SDoc -> IO ()) -- ^ Trace printer + :: Logger -> UnitConfig -> IO (UnitState,[UnitDatabase UnitId]) -mkUnitState ctx printer cfg = do +mkUnitState logger cfg = do {- Plan. @@ -1457,7 +1454,7 @@ mkUnitState ctx printer cfg = do -- if databases have not been provided, read the database flags raw_dbs <- case unitConfigDBCache cfg of - Nothing -> readUnitDatabases printer cfg + Nothing -> readUnitDatabases logger cfg Just dbs -> return dbs -- distrust all units if the flag is set @@ -1470,18 +1467,18 @@ mkUnitState ctx printer cfg = do -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order -- than they are on the command line. let other_flags = reverse (unitConfigFlagsExposed cfg) - printer 2 $ + debugTraceMsg logger 2 $ text "package flags" <+> ppr other_flags -- Merge databases together, without checking validity - (pkg_map1, prec_map) <- mergeDatabases (printer 2) dbs + (pkg_map1, prec_map) <- mergeDatabases logger dbs -- Now that we've merged everything together, prune out unusable -- packages. let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 - reportCycles (printer 2) sccs - reportUnusable (printer 2) unusable + reportCycles logger sccs + reportUnusable logger unusable -- Apply trust flags (these flags apply regardless of whether -- or not packages are visible or not) @@ -1554,7 +1551,7 @@ mkUnitState ctx printer cfg = do -- it modifies the unit ids of wired in packages, but when we process -- package arguments we need to key against the old versions. -- - (pkgs2, wired_map) <- findWiredInUnits (printer 2) prec_map pkgs1 vis_map2 + (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2 let pkg_db = mkUnitInfoMap pkgs2 -- Update the visibility map, so we treat wired packages as visible. @@ -1624,7 +1621,7 @@ mkUnitState ctx printer cfg = do $ closeUnitDeps pkg_db $ zip (map toUnitId preload3) (repeat Nothing) - let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map + let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable mod_map = Map.union mod_map1 mod_map2 @@ -1635,7 +1632,7 @@ mkUnitState ctx printer cfg = do , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet plugin_vis_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map , packageNameMap = pkgname_map , wireMap = wired_map , unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ] @@ -1659,13 +1656,13 @@ unwireUnit _ uid = uid -- packages a bit bothersome. mkModuleNameProvidersMap - :: SDocContext -- ^ SDocContext used to render exception messages + :: Logger -> UnitConfig -> UnitInfoMap -> PreloadUnitClosure -> VisibilityMap -> ModuleNameProvidersMap -mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map = +mkModuleNameProvidersMap logger cfg pkg_map closure vis_map = -- What should we fold on? Both situations are awkward: -- -- * Folding on the visibility map means that we won't create @@ -1716,7 +1713,8 @@ mkModuleNameProvidersMap ctx cfg pkg_map closure vis_map = rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) where origEntry = case lookupUFM esmap orig of Just r -> r - Nothing -> throwGhcException (CmdLineError (renderWithContext ctx + Nothing -> throwGhcException (CmdLineError (renderWithContext + (log_default_user_context (logFlags logger)) (text "package flag: could not find module name" <+> ppr orig <+> text "in package" <+> ppr pk))) diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 43692af28a..9a1ea88aa7 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -48,7 +48,7 @@ module GHC.Utils.Error ( -- * Issuing messages during compilation putMsg, printInfoForUser, printOutputForUser, logInfo, logOutput, - errorMsg, warningMsg, + errorMsg, fatalErrorMsg, fatalErrorMsg'', compilationProgressMsg, showPass, @@ -234,10 +234,10 @@ sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList Nothing -> id Just err_limit -> take err_limit -ghcExit :: Logger -> DynFlags -> Int -> IO () -ghcExit logger dflags val +ghcExit :: Logger -> Int -> IO () +ghcExit logger val | val == 0 = exitWith ExitSuccess - | otherwise = do errorMsg logger dflags (text "\nCompilation had errors\n\n") + | otherwise = do errorMsg logger (text "\nCompilation had errors\n\n") exitWith (ExitFailure val) doIfSet :: Bool -> IO () -> IO () @@ -251,45 +251,30 @@ doIfSet_dyn dflags flag action | gopt flag dflags = action -- ----------------------------------------------------------------------------- -- Outputting messages from the compiler --- We want all messages to go through one place, so that we can --- redirect them if necessary. For example, when GHC is used as a --- library we might want to catch all messages that GHC tries to --- output and do something else with them. - -ifVerbose :: DynFlags -> Int -> IO () -> IO () -ifVerbose dflags val act - | verbosity dflags >= val = act - | otherwise = return () -{-# INLINE ifVerbose #-} -- see Note [INLINE conditional tracing utilities] - -errorMsg :: Logger -> DynFlags -> SDoc -> IO () -errorMsg logger dflags msg - = putLogMsg logger dflags errorDiagnostic noSrcSpan $ - withPprStyle defaultErrStyle msg - -warningMsg :: Logger -> DynFlags -> SDoc -> IO () -warningMsg logger dflags msg - = putLogMsg logger dflags (mkMCDiagnostic dflags WarningWithoutFlag) noSrcSpan $ +errorMsg :: Logger -> SDoc -> IO () +errorMsg logger msg + = logMsg logger errorDiagnostic noSrcSpan $ withPprStyle defaultErrStyle msg -fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO () -fatalErrorMsg logger dflags msg = - putLogMsg logger dflags MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg +fatalErrorMsg :: Logger -> SDoc -> IO () +fatalErrorMsg logger msg = + logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg -compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO () -compilationProgressMsg logger dflags msg = do - let str = showSDoc dflags msg - traceEventIO $ "GHC progress: " ++ str - ifVerbose dflags 1 $ - logOutput logger dflags $ withPprStyle defaultUserStyle msg +compilationProgressMsg :: Logger -> SDoc -> IO () +compilationProgressMsg logger msg = do + let logflags = logFlags logger + let str = renderWithContext (log_default_user_context logflags) (text "GHC progress: " <> msg) + traceEventIO str + when (logVerbAtLeast logger 1) $ + logOutput logger $ withPprStyle defaultUserStyle msg -showPass :: Logger -> DynFlags -> String -> IO () -showPass logger dflags what - = ifVerbose dflags 2 $ - logInfo logger dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) +showPass :: Logger -> String -> IO () +showPass logger what = + when (logVerbAtLeast logger 2) $ + logInfo logger $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) data PrintTimings = PrintTimings | DontPrintTimings deriving (Eq, Show) @@ -320,14 +305,13 @@ data PrintTimings = PrintTimings | DontPrintTimings -- See Note [withTiming] for more. withTiming :: MonadIO m => Logger - -> DynFlags -- ^ DynFlags -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> m a -- ^ The body of the phase to be timed -> m a -withTiming logger dflags what force action = - withTiming' logger dflags what force PrintTimings action +withTiming logger what force action = + withTiming' logger what force PrintTimings action -- | Same as 'withTiming', but doesn't print timings in the -- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). @@ -336,31 +320,29 @@ withTiming logger dflags what force action = withTimingSilent :: MonadIO m => Logger - -> DynFlags -- ^ DynFlags -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> m a -- ^ The body of the phase to be timed -> m a -withTimingSilent logger dflags what force action = - withTiming' logger dflags what force DontPrintTimings action +withTimingSilent logger what force action = + withTiming' logger what force DontPrintTimings action -- | Worker for 'withTiming' and 'withTimingSilent'. withTiming' :: MonadIO m => Logger - -> DynFlags -- ^ 'DynFlags' -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> PrintTimings -- ^ Whether to print the timings -> m a -- ^ The body of the phase to be timed -> m a -withTiming' logger dflags what force_result prtimings action - = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags +withTiming' logger what force_result prtimings action + = if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings then do whenPrintTimings $ - logInfo logger dflags $ withPprStyle defaultUserStyle $ + logInfo logger $ withPprStyle defaultUserStyle $ text "***" <+> what <> colon - let ctx = initDefaultSDocContext dflags + let ctx = log_default_user_context (logFlags logger) alloc0 <- liftIO getAllocationCounter start <- liftIO getCPUTime eventBegins ctx what @@ -375,8 +357,8 @@ withTiming' logger dflags what force_result prtimings action let alloc = alloc0 - alloc1 time = realToFrac (end - start) * 1e-9 - when (verbosity dflags >= 2 && prtimings == PrintTimings) - $ liftIO $ logInfo logger dflags $ withPprStyle defaultUserStyle + when (logVerbAtLeast logger 2 && prtimings == PrintTimings) + $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle (text "!!!" <+> what <> colon <+> text "finished in" <+> doublePrec 2 time <+> text "milliseconds" @@ -386,7 +368,7 @@ withTiming' logger dflags what force_result prtimings action <+> text "megabytes") whenPrintTimings $ - dumpIfSet_dyn logger dflags Opt_D_dump_timings "" FormatText + putDumpFileMaybe logger Opt_D_dump_timings "" FormatText $ text $ showSDocOneLine ctx $ hsep [ what <> colon , text "alloc=" <> ppr alloc @@ -413,66 +395,57 @@ withTiming' logger dflags what force_result prtimings action eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w -debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO () -debugTraceMsg logger dflags val msg = - ifVerbose dflags val $ - logInfo logger dflags (withPprStyle defaultDumpStyle msg) +debugTraceMsg :: Logger -> Int -> SDoc -> IO () +debugTraceMsg logger val msg = + when (log_verbosity (logFlags logger) >= val) $ + logInfo logger (withPprStyle defaultDumpStyle msg) {-# INLINE debugTraceMsg #-} -- see Note [INLINE conditional tracing utilities] -putMsg :: Logger -> DynFlags -> SDoc -> IO () -putMsg logger dflags msg = logInfo logger dflags (withPprStyle defaultUserStyle msg) +putMsg :: Logger -> SDoc -> IO () +putMsg logger msg = logInfo logger (withPprStyle defaultUserStyle msg) -printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO () -printInfoForUser logger dflags print_unqual msg - = logInfo logger dflags (withUserStyle print_unqual AllTheWay msg) +printInfoForUser :: Logger -> PrintUnqualified -> SDoc -> IO () +printInfoForUser logger print_unqual msg + = logInfo logger (withUserStyle print_unqual AllTheWay msg) -printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO () -printOutputForUser logger dflags print_unqual msg - = logOutput logger dflags (withUserStyle print_unqual AllTheWay msg) +printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO () +printOutputForUser logger print_unqual msg + = logOutput logger (withUserStyle print_unqual AllTheWay msg) -logInfo :: Logger -> DynFlags -> SDoc -> IO () -logInfo logger dflags msg - = putLogMsg logger dflags MCInfo noSrcSpan msg +logInfo :: Logger -> SDoc -> IO () +logInfo logger msg = logMsg logger MCInfo noSrcSpan msg -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' -logOutput :: Logger -> DynFlags -> SDoc -> IO () -logOutput logger dflags msg - = putLogMsg logger dflags MCOutput noSrcSpan msg - - -prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a -prettyPrintGhcErrors dflags - = MC.handle $ \e -> case e of - PprPanic str doc -> - pprDebugAndThen ctx panic (text str) doc - PprSorry str doc -> - pprDebugAndThen ctx sorry (text str) doc - PprProgramError str doc -> - pprDebugAndThen ctx pgmError (text str) doc - _ -> - liftIO $ throwIO e - where - ctx = initSDocContext dflags defaultUserStyle - -traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a --- trace the command (at two levels of verbosity) -traceCmd logger dflags phase_name cmd_line action - = do { let verb = verbosity dflags - ; showPass logger dflags phase_name - ; debugTraceMsg logger dflags 3 (text cmd_line) - ; case flushErr dflags of - FlushErr io -> io - - -- And run it! - ; action `catchIO` handle_exn verb - } - where - handle_exn _verb exn = do { debugTraceMsg logger dflags 2 (char '\n') - ; debugTraceMsg logger dflags 2 - (text "Failed:" - <+> text cmd_line - <+> text (show exn)) - ; throwGhcExceptionIO (ProgramError (show exn))} +logOutput :: Logger -> SDoc -> IO () +logOutput logger msg = logMsg logger MCOutput noSrcSpan msg + + +prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a +prettyPrintGhcErrors logger = do + let ctx = log_default_user_context (logFlags logger) + MC.handle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen ctx panic (text str) doc + PprSorry str doc -> + pprDebugAndThen ctx sorry (text str) doc + PprProgramError str doc -> + pprDebugAndThen ctx pgmError (text str) doc + _ -> liftIO $ throwIO e + +-- | Trace a command (when verbosity level >= 3) +traceCmd :: Logger -> String -> String -> IO a -> IO a +traceCmd logger phase_name cmd_line action = do + showPass logger phase_name + let + cmd_doc = text cmd_line + handle_exn exn = do + debugTraceMsg logger 2 (char '\n') + debugTraceMsg logger 2 (text "Failed:" <+> cmd_doc <+> text (show exn)) + throwGhcExceptionIO (ProgramError (show exn)) + debugTraceMsg logger 3 cmd_doc + loggerTraceFlush logger + -- And run it! + action `catchIO` handle_exn {- Note [withTiming] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index 164aa4d387..77506682bd 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -1,20 +1,34 @@ {-# LANGUAGE RankNTypes #-} -- | Logger +-- +-- The Logger is an configurable entity that is used by the compiler to output +-- messages on the console (stdout, stderr) and in dump files. +-- +-- The behaviour of default Logger returned by `initLogger` can be modified with +-- hooks. The compiler itself uses hooks in multithreaded code (--make) and it +-- is also probably used by ghc-api users (IDEs, etc.). +-- +-- In addition to hooks, the Logger suppors LogFlags: basically a subset of the +-- command-line flags that control the logger behaviour at a higher level than +-- hooks. +-- +-- 1. Hooks are used to define how to generate a info/warning/error/dump messages +-- 2. LogFlags are used to decide when and how to generate messages +-- module GHC.Utils.Logger ( Logger - , initLogger , HasLogger (..) , ContainsLogger (..) + + -- * Logger setup + , initLogger , LogAction , DumpAction , TraceAction , DumpFormat (..) - , putLogMsg - , putDumpMsg - , putTraceMsg - -- * Hooks + -- ** Hooks , popLogHook , pushLogHook , popDumpHook @@ -23,27 +37,45 @@ module GHC.Utils.Logger , pushTraceHook , makeThreadSafe + -- ** Flags + , LogFlags (..) + , defaultLogFlags + , log_dopt + , log_set_dopt + , setLogFlags + , updateLogFlags + , logFlags + , logHasDumpFlag + , logVerbAtLeast + -- * Logging , jsonLogAction + , putLogMsg , defaultLogAction , defaultLogActionHPrintDoc , defaultLogActionHPutStrDoc + , logMsg + , logDumpMsg -- * Dumping , defaultDumpAction + , putDumpFile + , putDumpFileMaybe + , putDumpFileMaybe' , withDumpFileHandle , touchDumpFile - , dumpIfSet - , dumpIfSet_dyn - , dumpIfSet_dyn_printer + , logDumpFile -- * Tracing , defaultTraceAction + , putTraceMsg + , loggerTraceFlushUpdate + , loggerTraceFlush + , logTraceMsg ) where import GHC.Prelude -import GHC.Driver.Session import GHC.Driver.Flags import GHC.Driver.Ppr import GHC.Types.Error @@ -54,6 +86,9 @@ import GHC.Utils.Outputable import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet + import Data.IORef import System.Directory import System.FilePath ( takeDirectory, (</>) ) @@ -67,13 +102,79 @@ import Control.Monad import Control.Concurrent.MVar import System.IO.Unsafe -type LogAction = DynFlags +--------------------------------------------------------------- +-- Log flags +--------------------------------------------------------------- + +-- | Logger flags +data LogFlags = LogFlags + { log_default_user_context :: SDocContext + , log_default_dump_context :: SDocContext + , log_dump_flags :: !(EnumSet DumpFlag) -- ^ Dump flags + , log_show_caret :: !Bool -- ^ Show caret in diagnostics + , log_show_warn_groups :: !Bool -- ^ Show warning flag groups + , log_enable_timestamps :: !Bool -- ^ Enable timestamps + , log_dump_to_file :: !Bool -- ^ Enable dump to file + , log_dump_dir :: !(Maybe FilePath) -- ^ Dump directory + , log_dump_prefix :: !(Maybe FilePath) -- ^ Normal dump path ("basename.") + , log_dump_prefix_override :: !(Maybe FilePath) -- ^ Overriden dump path + , log_enable_debug :: !Bool -- ^ Enable debug output + , log_verbosity :: !Int -- ^ Verbosity level + } + +-- | Default LogFlags +defaultLogFlags :: LogFlags +defaultLogFlags = LogFlags + { log_default_user_context = defaultSDocContext + , log_default_dump_context = defaultSDocContext + , log_dump_flags = EnumSet.empty + , log_show_caret = True + , log_show_warn_groups = True + , log_enable_timestamps = True + , log_dump_to_file = False + , log_dump_dir = Nothing + , log_dump_prefix = Nothing + , log_dump_prefix_override = Nothing + , log_enable_debug = False + , log_verbosity = 0 + } + +-- | Test if a DumpFlag is enabled +log_dopt :: DumpFlag -> LogFlags -> Bool +log_dopt f logflags = f `EnumSet.member` log_dump_flags logflags + +-- | Enable a DumpFlag +log_set_dopt :: DumpFlag -> LogFlags -> LogFlags +log_set_dopt f logflags = logflags { log_dump_flags = EnumSet.insert f (log_dump_flags logflags) } + +-- | Test if a DumpFlag is set +logHasDumpFlag :: Logger -> DumpFlag -> Bool +logHasDumpFlag logger f = log_dopt f (logFlags logger) + +-- | Test if verbosity is >= to the given value +logVerbAtLeast :: Logger -> Int -> Bool +logVerbAtLeast logger v = log_verbosity (logFlags logger) >= v + +-- | Update LogFlags +updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger +updateLogFlags logger f = setLogFlags logger (f (logFlags logger)) + +-- | Set LogFlags +setLogFlags :: Logger -> LogFlags -> Logger +setLogFlags logger flags = logger { logFlags = flags } + + +--------------------------------------------------------------- +-- Logger +--------------------------------------------------------------- + +type LogAction = LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO () -type DumpAction = DynFlags +type DumpAction = LogFlags -> PprStyle -> DumpFlag -> String @@ -81,7 +182,7 @@ type DumpAction = DynFlags -> SDoc -> IO () -type TraceAction a = DynFlags -> String -> SDoc -> a -> a +type TraceAction a = LogFlags -> String -> SDoc -> a -> a -- | Format of a dump -- @@ -114,8 +215,28 @@ data Logger = Logger , generated_dumps :: DumpCache -- ^ Already dumped files (to append instead of overwriting them) + + , trace_flush :: IO () + -- ^ Flush the trace buffer + + , logFlags :: !LogFlags + -- ^ Logger flags } +-- | Set the trace flushing function +-- +-- The currently set trace flushing function is passed to the updating function +loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger +loggerTraceFlushUpdate logger upd = logger { trace_flush = upd (trace_flush logger) } + +-- | Calls the trace flushing function +loggerTraceFlush :: Logger -> IO () +loggerTraceFlush logger = trace_flush logger + +-- | Default trace flushing function (flush stderr) +defaultTraceFlush :: IO () +defaultTraceFlush = hFlush stderr + initLogger :: IO Logger initLogger = do dumps <- newIORef Set.empty @@ -124,6 +245,8 @@ initLogger = do , dump_hook = [] , trace_hook = [] , generated_dumps = dumps + , trace_flush = defaultTraceFlush + , logFlags = defaultLogFlags } -- | Log something @@ -131,8 +254,8 @@ putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) -- | Dump something -putDumpMsg :: Logger -> DumpAction -putDumpMsg logger = +putDumpFile :: Logger -> DumpAction +putDumpFile logger = let fallback = putLogMsg logger dumps = generated_dumps logger @@ -182,15 +305,15 @@ makeThreadSafe logger = do with_lock :: forall a. IO a -> IO a with_lock act = withMVar lock (const act) - log action dflags msg_class loc doc = - with_lock (action dflags msg_class loc doc) + log action logflags msg_class loc doc = + with_lock (action logflags msg_class loc doc) - dmp action dflags sty opts str fmt doc = - with_lock (action dflags sty opts str fmt doc) + dmp action logflags sty opts str fmt doc = + with_lock (action logflags sty opts str fmt doc) trc :: forall a. TraceAction a -> TraceAction a - trc action dflags str doc v = - unsafePerformIO (with_lock (return $! action dflags str doc v)) + trc action logflags str doc v = + unsafePerformIO (with_lock (return $! action logflags str doc v)) return $ pushLogHook log $ pushDumpHook dmp @@ -201,12 +324,12 @@ makeThreadSafe logger = do -- jsonLogAction :: LogAction jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message -jsonLogAction dflags msg_class srcSpan msg +jsonLogAction logflags msg_class srcSpan msg = - defaultLogActionHPutStrDoc dflags True stdout + defaultLogActionHPutStrDoc logflags True stdout (withPprStyle (PprCode CStyle) (doc $$ text "")) where - str = renderWithContext (initSDocContext dflags defaultUserStyle) msg + str = renderWithContext (log_default_user_context logflags) msg doc = renderJSON $ JSObject [ ( "span", json srcSpan ) , ( "doc" , JSString str ) @@ -214,8 +337,8 @@ jsonLogAction dflags msg_class srcSpan msg ] defaultLogAction :: LogAction -defaultLogAction dflags msg_class srcSpan msg - | dopt Opt_D_dump_json dflags = jsonLogAction dflags msg_class srcSpan msg +defaultLogAction logflags msg_class srcSpan msg + | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg | otherwise = case msg_class of MCOutput -> printOut msg MCDump -> printOut (msg $$ blankLine) @@ -225,16 +348,16 @@ defaultLogAction dflags msg_class srcSpan msg MCDiagnostic SevIgnore _ -> pure () -- suppress the message MCDiagnostic sev rea -> printDiagnostics sev rea where - printOut = defaultLogActionHPrintDoc dflags False stdout - printErrs = defaultLogActionHPrintDoc dflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout + printOut = defaultLogActionHPrintDoc logflags False stdout + printErrs = defaultLogActionHPrintDoc logflags False stderr + putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout -- Pretty print the warning flag, if any (#10752) message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg printDiagnostics severity reason = do hPutChar stderr '\n' caretDiagnostic <- - if gopt Opt_DiagnosticsShowCaret dflags + if log_show_caret logflags then getCaretDiagnostic msg_class srcSpan else pure empty printErrs $ getPprStyle $ \style -> @@ -262,26 +385,24 @@ defaultLogAction dflags msg_class srcSpan msg panic "SevWarning with ErrorWithoutFlag" warnFlagGrp flag - | gopt Opt_ShowWarnGroups dflags = + | log_show_warn_groups logflags = case smallestWarningGroups flag of [] -> "" groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" | otherwise = "" -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. -defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO () -defaultLogActionHPrintDoc dflags asciiSpace h d - = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "") +defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () +defaultLogActionHPrintDoc logflags asciiSpace h d + = defaultLogActionHPutStrDoc logflags asciiSpace h (d $$ text "") -- | The boolean arguments let's the pretty printer know if it can optimize indent -- by writing ascii ' ' characters without going through decoding. -defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO () -defaultLogActionHPutStrDoc dflags asciiSpace h d +defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () +defaultLogActionHPutStrDoc logflags asciiSpace h d -- Don't add a newline at the end, so that successive -- calls to this log-action can output all on the same line - = printSDoc ctx (Pretty.PageMode asciiSpace) h d - where - ctx = initSDocContext dflags defaultUserStyle + = printSDoc (log_default_dump_context logflags) (Pretty.PageMode asciiSpace) h d -- -- Note [JSON Error Messages] @@ -301,8 +422,8 @@ defaultLogActionHPutStrDoc dflags asciiSpace h d -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction -defaultDumpAction dumps log_action dflags sty flag title _fmt doc = - dumpSDocWithStyle dumps log_action sty dflags flag title doc +defaultDumpAction dumps log_action logflags sty flag title _fmt doc = + dumpSDocWithStyle dumps log_action sty logflags flag title doc -- | Write out a dump. -- @@ -311,38 +432,37 @@ defaultDumpAction dumps log_action dflags sty flag title _fmt doc = -- -- When @hdr@ is empty, we print in a more compact format (no separators and -- blank lines) -dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpSDocWithStyle dumps log_action sty dflags flag hdr doc = - withDumpFileHandle dumps dflags flag writeDump +dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> LogFlags -> DumpFlag -> String -> SDoc -> IO () +dumpSDocWithStyle dumps log_action sty logflags flag hdr doc = + withDumpFileHandle dumps logflags flag writeDump where -- write dump to file writeDump (Just handle) = do doc' <- if null hdr then return doc - else do t <- getCurrentTime - let timeStamp = if (gopt Opt_SuppressTimestamps dflags) - then empty - else text (show t) + else do timeStamp <- if log_enable_timestamps logflags + then (text . show) <$> getCurrentTime + else pure empty let d = timeStamp $$ blankLine $$ doc return $ mkDumpDoc hdr d -- When we dump to files we use UTF8. Which allows ascii spaces. - defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc') + defaultLogActionHPrintDoc logflags True handle (withPprStyle sty doc') -- write the dump to stdout writeDump Nothing = do let (doc', msg_class) | null hdr = (doc, MCOutput) | otherwise = (mkDumpDoc hdr doc, MCDump) - log_action dflags msg_class noSrcSpan (withPprStyle sty doc') + log_action logflags msg_class noSrcSpan (withPprStyle sty doc') -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a -- file, otherwise 'Nothing'. -withDumpFileHandle :: DumpCache -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () -withDumpFileHandle dumps dflags flag action = do - let mFile = chooseDumpFile dflags flag +withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dumps logflags flag action = do + let mFile = chooseDumpFile logflags flag case mFile of Just fileName -> do gd <- readIORef dumps @@ -361,10 +481,10 @@ withDumpFileHandle dumps dflags flag action = do action (Just handle) Nothing -> action Nothing --- | Choose where to put a dump file based on DynFlags and DumpFlag -chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath -chooseDumpFile dflags flag - | gopt Opt_DumpToFile dflags || forced_to_file +-- | Choose where to put a dump file based on LogFlags and DumpFlag +chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath +chooseDumpFile logflags flag + | log_dump_to_file logflags || forced_to_file , Just prefix <- getPrefix = Just $ setDir (prefix ++ dump_suffix) @@ -389,27 +509,46 @@ chooseDumpFile dflags flag getPrefix -- dump file location is being forced -- by the --ddump-file-prefix flag. - | Just prefix <- dumpPrefixForce dflags + | Just prefix <- log_dump_prefix_override logflags = Just prefix -- dump file location chosen by GHC.Driver.Pipeline.runPipeline - | Just prefix <- dumpPrefix dflags + | Just prefix <- log_dump_prefix logflags = Just prefix -- we haven't got a place to put a dump file. | otherwise = Nothing - setDir f = case dumpDir dflags of + setDir f = case log_dump_dir logflags of Just d -> d </> f Nothing -> f --- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated --- despite the fact that 'dumpIfSet' has an @INLINE@. -doDump :: Logger -> DynFlags -> String -> SDoc -> IO () -doDump logger dflags hdr doc = - putLogMsg logger dflags - MCDump - noSrcSpan - (withPprStyle defaultDumpStyle - (mkDumpDoc hdr doc)) + + +-- | Default action for 'traceAction' hook +defaultTraceAction :: TraceAction a +defaultTraceAction logflags title doc x = + if not (log_enable_debug logflags) + then x + else trace (showSDocDump (log_default_dump_context logflags) + (sep [text title, nest 2 doc])) x + + +-- | Log something +logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () +logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg + +-- | Dump something +logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +logDumpFile logger = putDumpFile logger (logFlags logger) + +-- | Log a trace message +logTraceMsg :: Logger -> String -> SDoc -> a -> a +logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a + +-- | Log a dump message (not a dump file) +logDumpMsg :: Logger -> String -> SDoc -> IO () +logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan + (withPprStyle defaultDumpStyle + (mkDumpDoc hdr doc)) mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc @@ -421,50 +560,32 @@ mkDumpDoc hdr doc line = text "====================" -dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO () -dumpIfSet logger dflags flag hdr doc - | not flag = return () - | otherwise = doDump logger dflags hdr doc -{-# INLINE dumpIfSet #-} -- see Note [INLINE conditional tracing utilities] - --- | A wrapper around 'dumpAction'. --- First check whether the dump flag is set --- Do nothing if it is unset -dumpIfSet_dyn :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify -{-# INLINE dumpIfSet_dyn #-} -- see Note [INLINE conditional tracing utilities] +-- | Dump if the given DumpFlag is set +putDumpFileMaybe :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +putDumpFileMaybe logger = putDumpFileMaybe' logger alwaysQualify +{-# INLINE putDumpFileMaybe #-} -- see Note [INLINE conditional tracing utilities] --- | A wrapper around 'putDumpMsg'. --- First check whether the dump flag is set --- Do nothing if it is unset +-- | Dump if the given DumpFlag is set -- --- Unlike 'dumpIfSet_dyn', has a printer argument -dumpIfSet_dyn_printer - :: PrintUnqualified - -> Logger - -> DynFlags +-- Unlike 'putDumpFileMaybe', has a PrintUnqualified argument +putDumpFileMaybe' + :: Logger + -> PrintUnqualified -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -dumpIfSet_dyn_printer printer logger dflags flag hdr fmt doc - = when (dopt flag dflags) $ do +putDumpFileMaybe' logger printer flag hdr fmt doc + = when (logHasDumpFlag logger flag) $ do let sty = mkDumpStyle printer - putDumpMsg logger dflags sty flag hdr fmt doc -{-# INLINE dumpIfSet_dyn_printer #-} -- see Note [INLINE conditional tracing utilities] + logDumpFile logger sty flag hdr fmt doc +{-# INLINE putDumpFileMaybe' #-} -- see Note [INLINE conditional tracing utilities] -- | Ensure that a dump file is created even if it stays empty -touchDumpFile :: Logger -> DynFlags -> DumpFlag -> IO () -touchDumpFile logger dflags flag = - withDumpFileHandle (generated_dumps logger) dflags flag (const (return ())) - - --- | Default action for 'traceAction' hook -defaultTraceAction :: TraceAction a -defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc - - +touchDumpFile :: Logger -> DumpFlag -> IO () +touchDumpFile logger flag = + withDumpFileHandle (generated_dumps logger) (logFlags logger) flag (const (return ())) class HasLogger m where getLogger :: m Logger diff --git a/compiler/GHC/Utils/TmpFs.hs b/compiler/GHC/Utils/TmpFs.hs index fb671ad486..2244a898ff 100644 --- a/compiler/GHC/Utils/TmpFs.hs +++ b/compiler/GHC/Utils/TmpFs.hs @@ -141,7 +141,7 @@ cleanTempDirs logger tmpfs dflags $ mask_ $ do let ref = tmp_dirs_to_clean tmpfs ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) - removeTmpDirs logger dflags (Map.elems ds) + removeTmpDirs logger (Map.elems ds) -- | Delete all files in @tmp_files_to_clean@. cleanTempFiles :: Logger -> TmpFs -> DynFlags -> IO () @@ -155,7 +155,7 @@ cleanTempFiles logger tmpfs dflags , ftcGhcSession = gs_files } -> ( emptyFilesToClean , Set.toList cm_files ++ Set.toList gs_files) - removeTmpFiles logger dflags to_delete + removeTmpFiles logger to_delete -- | Delete all files in @tmp_files_to_clean@. That have lifetime -- TFL_CurrentModule. @@ -169,7 +169,7 @@ cleanCurrentModuleTempFiles logger tmpfs dflags to_delete <- atomicModifyIORef' ref $ \ftc@FilesToClean{ftcCurrentModule = cm_files} -> (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) - removeTmpFiles logger dflags to_delete + removeTmpFiles logger to_delete -- | Ensure that new_files are cleaned on the next call of -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. @@ -294,7 +294,7 @@ getTempDir logger tmpfs dflags = do -- directory we created. Otherwise return the directory we created. case their_dir of Nothing -> do - debugTraceMsg logger dflags 2 $ + debugTraceMsg logger 2 $ text "Created temporary directory:" <+> text our_dir return our_dir Just dir -> do @@ -314,18 +314,18 @@ the process id). This is ok, as the temporary directory used contains the pid (see getTempDir). -} -removeTmpDirs :: Logger -> DynFlags -> [FilePath] -> IO () -removeTmpDirs logger dflags ds - = traceCmd logger dflags "Deleting temp dirs" +removeTmpDirs :: Logger -> [FilePath] -> IO () +removeTmpDirs logger ds + = traceCmd logger "Deleting temp dirs" ("Deleting: " ++ unwords ds) - (mapM_ (removeWith logger dflags removeDirectory) ds) + (mapM_ (removeWith logger removeDirectory) ds) -removeTmpFiles :: Logger -> DynFlags -> [FilePath] -> IO () -removeTmpFiles logger dflags fs +removeTmpFiles :: Logger -> [FilePath] -> IO () +removeTmpFiles logger fs = warnNon $ - traceCmd logger dflags "Deleting temp files" + traceCmd logger "Deleting temp files" ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith logger dflags removeFile) deletees) + (mapM_ (removeWith logger removeFile) deletees) where -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source @@ -336,21 +336,21 @@ removeTmpFiles logger dflags fs warnNon act | null non_deletees = act | otherwise = do - putMsg logger dflags (text "WARNING - NOT deleting source files:" - <+> hsep (map text non_deletees)) + putMsg logger (text "WARNING - NOT deleting source files:" + <+> hsep (map text non_deletees)) act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs -removeWith :: Logger -> DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () -removeWith logger dflags remover f = remover f `Exception.catchIO` +removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO () +removeWith logger remover f = remover f `Exception.catchIO` (\e -> let msg = if isDoesNotExistError e then text "Warning: deleting non-existent" <+> text f else text "Warning: exception raised when deleting" <+> text f <> colon $$ text (show e) - in debugTraceMsg logger dflags 2 msg + in debugTraceMsg logger 2 msg ) #if defined(mingw32_HOST_OS) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 5d8d1f9b22..a1a1d967cd 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -388,6 +388,9 @@ Library GHC.Driver.CmdLine GHC.Driver.CodeOutput GHC.Driver.Config + GHC.Driver.Config.CmmToAsm + GHC.Driver.Config.Logger + GHC.Driver.Config.Parser GHC.Driver.Env GHC.Driver.Env.Types GHC.Driver.Errors diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst index 99a95c0027..340c324614 100644 --- a/docs/users_guide/extending_ghc.rst +++ b/docs/users_guide/extending_ghc.rst @@ -1345,12 +1345,9 @@ this idea can be seen below: hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv hooksP opts hsc_env = do - let dflags = hsc_dflags hsc_env - dflags' = dflags - { hooks = (hooks dflags) - { runMetaHook = Just (fakeRunMeta opts) } - } - hsc_env' = hsc_env { hsc_dflags = dflags' } + let hooks' = (hsc_hooks hsc_env) + { runMetaHook = Just (fakeRunMeta opts) } + hsc_env' = hsc_env { hsc_hooks = hooks' } return hsc_env' -- This meta hook doesn't actually care running code in splices, diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 7176b1e596..001caf1fff 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -51,7 +51,7 @@ import GHC.Driver.Session as DynFlags import GHC.Driver.Ppr hiding (printForUser) import GHC.Utils.Error hiding (traceCmd) import GHC.Driver.Monad ( modifySession ) -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Resume, SingleStep, Ghc, @@ -3117,9 +3117,10 @@ newDynFlags interactive_only minus_opts = do newLdInputs = drop ld0length (ldInputs dflags2) newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2) - hsc_env' = hsc_env { hsc_dflags = - dflags2 { ldInputs = newLdInputs - , cmdlineFrameworks = newCLFrameworks } } + dflags' = dflags2 { ldInputs = newLdInputs + , cmdlineFrameworks = newCLFrameworks + } + hsc_env' = hscSetFlags dflags' hsc_env when (not (null newLdInputs && null newCLFrameworks)) $ liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env' @@ -4462,11 +4463,11 @@ showException se = -- in an exception loop (eg. let a = error a in a) the ^C exception -- may never be delivered. Thanks to Marcin for pointing out the bug. -ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a +ghciHandle :: (HasLogger m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a ghciHandle h m = mask $ \restore -> do -- Force dflags to avoid leaking the associated HscEnv - !dflags <- getDynFlags - catch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e) + !log <- getLogger + catch (restore (GHC.prettyPrintGhcErrors log m)) $ \e -> restore (h e) ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a) ghciTry m = fmap Right m `catch` \e -> return $ Left e diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 888b536d01..a24c40e804 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -19,7 +19,7 @@ module GHCi.UI.Monad ( PromptFunction, BreakLocation(..), TickArray, - getDynFlags, + extractDynFlags, getDynFlags, runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs, ActionStats(..), runAndPrintStats, runWithStats, printStats, @@ -522,9 +522,8 @@ runInternal :: GhcMonad m => m a -> m a runInternal = withTempSession mkTempSession where - mkTempSession hsc_env = hsc_env - { hsc_dflags = (hsc_dflags hsc_env) { - -- Running GHCi's internal expression is incompatible with -XSafe. + mkTempSession = hscUpdateFlags (\dflags -> dflags + { -- Running GHCi's internal expression is incompatible with -XSafe. -- We temporarily disable any Safe Haskell settings while running -- GHCi internal expressions. (see #12509) safeHaskell = Sf_None, @@ -539,7 +538,7 @@ runInternal = -- We heavily depend on -fimplicit-import-qualified to compile expr -- with fully qualified names without imports. `gopt_set` Opt_ImplicitImportQualified - } + ) compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr diff --git a/ghc/Main.hs b/ghc/Main.hs index 2873cba4ad..9f0dc68ec5 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -29,6 +29,7 @@ import GHC.Driver.Pipeline ( oneShot, compileFile ) import GHC.Driver.MakeFile ( doMkDependHS ) import GHC.Driver.Backpack ( doBackpack ) import GHC.Driver.Plugins +import GHC.Driver.Config.Logger (initLogFlags) import GHC.Platform import GHC.Platform.Ways @@ -152,7 +153,6 @@ main = do main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn] -> Ghc () main' postLoadMode dflags0 args flagWarnings = do - logger <- getLogger -- set the default GhcMode, backend and GhcLink. The backend -- can be further adjusted on a module by module basis, using only @@ -192,10 +192,13 @@ main' postLoadMode dflags0 args flagWarnings = do `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges + logger1 <- getLogger + let logger2 = setLogFlags logger1 (initLogFlags dflags2) + -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files (dflags3, fileish_args, dynamicFlagWarnings) <- - GHC.parseDynamicFlags logger dflags2 args + GHC.parseDynamicFlags logger2 dflags2 args let dflags4 = case bcknd of Interpreter | not (gopt Opt_ExternalInterpreter dflags3) -> @@ -211,14 +214,16 @@ main' postLoadMode dflags0 args flagWarnings = do _ -> dflags3 - GHC.prettyPrintGhcErrors dflags4 $ do + let logger4 = setLogFlags logger2 (initLogFlags dflags4) + + GHC.prettyPrintGhcErrors logger4 $ do let flagWarnings' = flagWarnings ++ dynamicFlagWarnings handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do - liftIO $ handleFlagWarnings logger dflags4 flagWarnings' + liftIO $ handleFlagWarnings logger4 dflags4 flagWarnings' liftIO $ showBanner postLoadMode dflags4 @@ -228,6 +233,7 @@ main' postLoadMode dflags0 args flagWarnings = do _ <- GHC.setSessionDynFlags dflags5 dflags6 <- GHC.getSessionDynFlags hsc_env <- GHC.getSession + logger <- getLogger ---------------- Display configuration ----------- case verbosity dflags6 of @@ -244,7 +250,7 @@ main' postLoadMode dflags0 args flagWarnings = do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do case postLoadMode of - ShowInterface f -> liftIO $ showIface (hsc_logger hsc_env) + ShowInterface f -> liftIO $ showIface logger (hsc_dflags hsc_env) (hsc_units hsc_env) (hsc_NC hsc_env) @@ -259,7 +265,7 @@ main' postLoadMode dflags0 args flagWarnings = do DoFrontend f -> doFrontend f srcs DoBackpack -> doBackpack (map fst srcs) - liftIO $ dumpFinalStats logger dflags6 + liftIO $ dumpFinalStats logger ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () #if !defined(HAVE_INTERNAL_INTERPRETER) @@ -760,19 +766,19 @@ showUsage ghci dflags = do dump ('$':'$':s) = putStr progName >> dump s dump (c:s) = putChar c >> dump s -dumpFinalStats :: Logger -> DynFlags -> IO () -dumpFinalStats logger dflags = do - when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats logger dflags +dumpFinalStats :: Logger -> IO () +dumpFinalStats logger = do + when (logHasDumpFlag logger Opt_D_faststring_stats) $ dumpFastStringStats logger - when (dopt Opt_D_dump_faststrings dflags) $ do + when (logHasDumpFlag logger Opt_D_dump_faststrings) $ do fss <- getFastStringTable let ppr_table = fmap ppr_segment (fss `zip` [0..]) ppr_segment (s,n) = hang (text "Segment" <+> int n) 2 (vcat (fmap ppr_bucket (s `zip` [0..]))) ppr_bucket (b,n) = hang (text "Bucket" <+> int n) 2 (vcat (fmap ftext b)) - dumpIfSet_dyn logger dflags Opt_D_dump_faststrings "FastStrings" FormatText (vcat ppr_table) + putDumpFileMaybe logger Opt_D_dump_faststrings "FastStrings" FormatText (vcat ppr_table) -dumpFastStringStats :: Logger -> DynFlags -> IO () -dumpFastStringStats logger dflags = do +dumpFastStringStats :: Logger -> IO () +dumpFastStringStats logger = do segments <- getFastStringTable hasZ <- getFastStringZEncCounter let buckets = concat segments @@ -793,14 +799,14 @@ dumpFastStringStats logger dflags = do -- which is not counted as "z-encoded". Only strings whose -- Z-encoding is different from the original string are counted in -- the "z-encoded" total. - putMsg logger dflags msg + putMsg logger msg where x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' showUnits, dumpUnits, dumpUnitsSimple :: HscEnv -> IO () showUnits hsc_env = putStrLn (showSDoc (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env))) -dumpUnits hsc_env = putMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env)) -dumpUnitsSimple hsc_env = putMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) (pprUnitsSimple (hsc_units hsc_env)) +dumpUnits hsc_env = putMsg (hsc_logger hsc_env) (pprUnits (hsc_units hsc_env)) +dumpUnitsSimple hsc_env = putMsg (hsc_logger hsc_env) (pprUnitsSimple (hsc_units hsc_env)) -- ----------------------------------------------------------------------------- -- Frontend plugin support diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs index 64800dd243..7f51426823 100644 --- a/testsuite/tests/callarity/unittest/CallArity1.hs +++ b/testsuite/tests/callarity/unittest/CallArity1.hs @@ -173,16 +173,16 @@ main = do logger <- getLogger liftIO $ forM_ exprs $ \(n,e) -> do case lintExpr dflags [f,scrutf,scruta] e of - Just errs -> putMsg logger dflags (pprMessageBag errs $$ text "in" <+> text n) + Just errs -> putMsg logger (pprMessageBag errs $$ text "in" <+> text n) Nothing -> return () - putMsg logger dflags (text n Outputable.<> char ':') - -- liftIO $ putMsg dflags (ppr e) + putMsg logger (text n Outputable.<> char ':') + -- liftIO $ putMsg logger (ppr e) let e' = callArityRHS e let bndrs = nonDetEltsUniqSet (allBoundIds e') -- It should be OK to use nonDetEltsUniqSet here, if it becomes a -- problem we should use DVarSet - -- liftIO $ putMsg dflags (ppr e') - forM_ bndrs $ \v -> putMsg logger dflags $ nest 4 $ ppr v <+> ppr (idCallArity v) + -- liftIO $ putMsg logger (ppr e') + forM_ bndrs $ \v -> putMsg logger $ nest 4 $ ppr v <+> ppr (idCallArity v) -- Utilities mkLApps :: Id -> [Integer] -> CoreExpr diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 4b33ad2982..8411e66318 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,4 +1,4 @@ -Found 266 Language.Haskell.Syntax module dependencies +Found 267 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -82,6 +82,7 @@ GHC.Data.StringBuffer GHC.Data.TrieMap GHC.Driver.Backend GHC.Driver.CmdLine +GHC.Driver.Config.Logger GHC.Driver.Env GHC.Driver.Env.Types GHC.Driver.Errors diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 16dbb8e185..d6878d6bd5 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,4 +1,4 @@ -Found 272 GHC.Parser module dependencies +Found 273 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -83,6 +83,7 @@ GHC.Data.TrieMap GHC.Driver.Backend GHC.Driver.Backpack.Syntax GHC.Driver.CmdLine +GHC.Driver.Config.Logger GHC.Driver.Env GHC.Driver.Env.Types GHC.Driver.Errors diff --git a/testsuite/tests/ghc-api/T11579.hs b/testsuite/tests/ghc-api/T11579.hs index f2beeb3035..fc8c2c5fff 100644 --- a/testsuite/tests/ghc-api/T11579.hs +++ b/testsuite/tests/ghc-api/T11579.hs @@ -1,6 +1,6 @@ import System.Environment import GHC.Driver.Session -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) import GHC.Data.FastString import GHC import GHC.Data.StringBuffer diff --git a/testsuite/tests/ghc-api/T7478/T7478.hs b/testsuite/tests/ghc-api/T7478/T7478.hs index dbea3f9547..b31a5688a6 100644 --- a/testsuite/tests/ghc-api/T7478/T7478.hs +++ b/testsuite/tests/ghc-api/T7478/T7478.hs @@ -24,6 +24,10 @@ compileInGhc targets handlerOutput = do flags0 <- getSessionDynFlags let flags = flags0 {verbosity = 1 } setSessionDynFlags flags + let collectSrcError handlerOutput _flags MCOutput _srcspan msg + = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg + collectSrcError _ _ _ _ _ + = return () pushLogHookM (const (collectSrcError handlerOutput)) -- Set up targets. oldTargets <- getTargets @@ -48,10 +52,6 @@ compileInGhc targets handlerOutput = do TargetFile file Nothing -> file _ -> error "fileFromTarget: not a known target" - collectSrcError handlerOutput flags MCOutput _srcspan msg - = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg - collectSrcError _ _ _ _ _ - = return () main :: IO () main = do diff --git a/testsuite/tests/ghc-api/T9015.hs b/testsuite/tests/ghc-api/T9015.hs index 3ca05afc7d..b97ec34a60 100644 --- a/testsuite/tests/ghc-api/T9015.hs +++ b/testsuite/tests/ghc-api/T9015.hs @@ -3,7 +3,7 @@ module Main where import GHC import GHC.Driver.Session import GHC.Driver.Monad -import GHC.Driver.Config +import GHC.Driver.Config.Parser (initParserOpts) import System.Environment testStrings = [ diff --git a/testsuite/tests/plugins/static-plugins.hs b/testsuite/tests/plugins/static-plugins.hs index b263c01b1d..73d91a93e3 100644 --- a/testsuite/tests/plugins/static-plugins.hs +++ b/testsuite/tests/plugins/static-plugins.hs @@ -2,7 +2,7 @@ module Main where import GHC.Driver.Env import GHC.Driver.Session - (getDynFlags, parseDynamicFlagsCmdLine, defaultFatalMessager, defaultFlushOut) + (extractDynFlags, parseDynamicFlagsCmdLine, defaultFatalMessager, defaultFlushOut) import GHC.Driver.Plugins import GHC.Driver.Monad diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index f68cd040df..419a723062 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.CmmToAsm import GHC.Driver.Main import GHC.Driver.Env import GHC.StgToCmm.CgUtils @@ -44,6 +45,7 @@ import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Driver.Errors import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Utils.Outputable import GHC.Types.Basic import GHC.Unit.Home @@ -64,8 +66,15 @@ main = do --get a GHC context and run the tests runGhc (Just libdir) $ do - dflags0 <- fmap setOptions getDynFlags - setSessionDynFlags dflags0 + dflags0 <- flip gopt_set Opt_RegsGraph <$> getDynFlags + --the register allocator's intermediate data + --structures are usually discarded + --(in GHC.CmmToAsm.cmmNativeGen) for performance + --reasons. To prevent this we need to tell + --cmmNativeGen we want them printed out even + --though we ignore stderr in the test configuration. + let dflags1 = dopt_set dflags0 Opt_D_dump_asm_stats + setSessionDynFlags dflags1 dflags <- getDynFlags logger <- getLogger @@ -75,8 +84,6 @@ main = do return () - where setOptions = (flip gopt_set) Opt_RegsGraph - -- | TODO: Make this an IORef along the lines of Data.Unique.newUnique to add -- stronger guarantees a UniqSupply won't be accidentally reused @@ -113,7 +120,7 @@ compileCmmForRegAllocStats :: UniqSupply -> IO [( Maybe [Color.RegAllocStats (Alignment, RawCmmStatics) X86.Instr.Instr] , Maybe [Linear.RegAllocStats])] -compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do +compileCmmForRegAllocStats logger dflags cmmFile ncgImplF us = do let ncgImpl = ncgImplF (initNCGConfig dflags thisMod) hscEnv <- newHscEnv dflags @@ -127,13 +134,14 @@ compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do let initTopSRT = emptySRT thisMod cmmGroup <- fmap snd $ cmmPipeline hscEnv initTopSRT $ fst $ fromJust parsedCmm - rawCmms <- cmmToRawCmm logger dflags (Stream.yield cmmGroup) + let profile = targetProfile dflags + rawCmms <- cmmToRawCmm logger profile (Stream.yield cmmGroup) collectedCmms <- mconcat <$> Stream.collect rawCmms -- compile and discard the generated code, returning regalloc stats mapM (\ (count, thisCmm) -> - cmmNativeGen logger dflags thisModLoc ncgImpl + cmmNativeGen logger thisModLoc ncgImpl usb dwarfFileIds dbgMap thisCmm count >>= (\(_, _, _, _, colorStats, linearStats, _) -> -- scrub unneeded output from cmmNativeGen @@ -141,13 +149,6 @@ compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do $ zip [0.. (length collectedCmms)] collectedCmms where - --the register allocator's intermediate data - --structures are usually discarded - --(in AsmCodeGen.cmmNativeGen) for performance - --reasons. To prevent this we need to tell - --cmmNativeGen we want them printed out even - --though we ignore stderr in the test configuration. - dflags = dopt_set dflags' Opt_D_dump_asm_stats [usa, usb, usc, usd] = take 4 . listSplitUniqSupply $ us -- don't need debugging information dwarfFileIds = emptyUFM diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs index 4620ae3fa1..5d8b180cd4 100644 --- a/utils/check-exact/Parsers.hs +++ b/utils/check-exact/Parsers.hs @@ -53,7 +53,7 @@ import qualified GHC hiding (parseModule) import qualified Control.Monad.IO.Class as GHC import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC -import qualified GHC.Driver.Config as GHC +import qualified GHC.Driver.Config.Parser as GHC import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.Parser as GHC diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs index 245305a677..a085648f36 100644 --- a/utils/check-exact/Preprocess.hs +++ b/utils/check-exact/Preprocess.hs @@ -18,7 +18,7 @@ import qualified GHC as GHC hiding (parseModule) import qualified Control.Monad.IO.Class as GHC import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC -import qualified GHC.Driver.Config as GHC +import qualified GHC.Driver.Config.Parser as GHC import qualified GHC.Driver.Env as GHC import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Phases as GHC @@ -209,8 +209,8 @@ getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m) -> m (String, GHC.StringBuffer, GHC.DynFlags) getPreprocessedSrcDirectPrim cppOptions src_fn = do hsc_env <- GHC.getSession - let dfs = GHC.hsc_dflags hsc_env - new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs } + let dflags = GHC.hsc_dflags hsc_env + new_env = GHC.hscSetFlags (injectCppOptions cppOptions dflags) hsc_env r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile)) case r of Left err -> error $ showErrorMessages err |