diff options
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 |