diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2021-01-07 14:25:15 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-02-13 21:27:34 -0500 |
| commit | 8e2f85f6b4662676f0d7addaff9bf2c7d751bb63 (patch) | |
| tree | 6a5bea5db12d907874cdf26d709d829a3f3216ba | |
| parent | 40983d2331fe34c0af6925db7588d5ac6a19ae36 (diff) | |
| download | haskell-8e2f85f6b4662676f0d7addaff9bf2c7d751bb63.tar.gz | |
Refactor Logger
Before this patch, the only way to override GHC's default logging
behavior was to set `log_action`, `dump_action` and `trace_action`
fields in DynFlags. This patch introduces a new Logger abstraction and
stores it in HscEnv instead.
This is part of #17957 (avoid storing state in DynFlags). DynFlags are
duplicated and updated per-module (because of OPTIONS_GHC pragma), so
we shouldn't store global state in them.
This patch also fixes a race in parallel "--make" mode which updated
the `generatedDumps` IORef concurrently.
Bump haddock submodule
The increase in MultilayerModules is tracked in #19293.
Metric Increase:
MultiLayerModules
88 files changed, 1901 insertions, 1543 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index eef40f6c2b..fb63b10785 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -31,10 +31,17 @@ module GHC ( GhcMode(..), GhcLink(..), parseDynamicFlags, parseTargetFiles, getSessionDynFlags, setSessionDynFlags, - getProgramDynFlags, setProgramDynFlags, setLogAction, + getProgramDynFlags, setProgramDynFlags, getInteractiveDynFlags, setInteractiveDynFlags, interpretPackageEnv, + -- * Logging + Logger, getLogger, + pushLogHook, popLogHook, + pushLogHookM, popLogHookM, modifyLogger, + putMsgM, putLogMsgM, + + -- * Targets Target(..), TargetId(..), Phase, setTargets, @@ -353,6 +360,7 @@ import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Core.Predicate import GHC.Core.Type hiding( typeKind ) @@ -524,9 +532,10 @@ withCleanupSession ghc = ghc `MC.finally` cleanup cleanup = do hsc_env <- getSession let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env liftIO $ do - cleanTempFiles dflags - cleanTempDirs dflags + cleanTempFiles logger dflags + cleanTempDirs logger dflags stopInterp hsc_env -- shut down the IServ -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further @@ -551,11 +560,12 @@ initGhcMonad mb_top_dir ; mySettings <- initSysTools top_dir ; myLlvmConfig <- lazyInitLlvmConfig top_dir ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) - ; checkBrokenTablesNextToCode dflags + ; hsc_env <- newHscEnv dflags + ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags ; setUnsafeGlobalDynFlags dflags -- c.f. DynFlags.parseDynamicFlagsFull, which -- creates DynFlags and sets the UnsafeGlobalDynFlags - ; newHscEnv dflags } + ; return hsc_env } ; setSession env } -- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which @@ -564,9 +574,9 @@ initGhcMonad mb_top_dir -- version where this bug is fixed. -- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and -- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 -checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () -checkBrokenTablesNextToCode dflags - = do { broken <- checkBrokenTablesNextToCode' dflags +checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m () +checkBrokenTablesNextToCode logger dflags + = do { broken <- checkBrokenTablesNextToCode' logger dflags ; when broken $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr ; liftIO $ fail "unsupported linker" @@ -577,13 +587,13 @@ checkBrokenTablesNextToCode dflags text "when using binutils ld (please see:" <+> text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" -checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool -checkBrokenTablesNextToCode' dflags +checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool +checkBrokenTablesNextToCode' logger dflags | not (isARM arch) = return False | WayDyn `S.notMember` ways dflags = return False | not tablesNextToCode = return False | otherwise = do - linkerInfo <- liftIO $ getLinkerInfo dflags + linkerInfo <- liftIO $ getLinkerInfo logger dflags case linkerInfo of GnuLD _ -> return True _ -> return False @@ -627,9 +637,10 @@ checkBrokenTablesNextToCode' dflags -- (packageFlags dflags). setSessionDynFlags :: GhcMonad m => DynFlags -> m () setSessionDynFlags dflags0 = do - dflags <- checkNewDynFlags dflags0 + logger <- getLogger + dflags <- checkNewDynFlags logger dflags0 hsc_env <- getSession - (dbs,unit_state,home_unit) <- liftIO $ initUnits dflags (hsc_unit_dbs hsc_env) + (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags (hsc_unit_dbs hsc_env) -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags @@ -644,7 +655,7 @@ setSessionDynFlags dflags0 = do | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 - then return (logInfo dflags $ withPprStyle defaultDumpStyle msg) + then return (logInfo logger dflags $ withPprStyle defaultDumpStyle msg) else return (pure ()) let conf = IServConfig @@ -689,24 +700,16 @@ setSessionDynFlags dflags0 = do setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool setProgramDynFlags dflags = setProgramDynFlags_ True dflags --- | Set the action taken when the compiler produces a message. This --- can also be accomplished using 'setProgramDynFlags', but using --- 'setLogAction' avoids invalidating the cached module graph. -setLogAction :: GhcMonad m => LogAction -> m () -setLogAction action = do - dflags' <- getProgramDynFlags - void $ setProgramDynFlags_ False $ - dflags' { log_action = action } - setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool setProgramDynFlags_ invalidate_needed dflags = do - dflags' <- checkNewDynFlags dflags + logger <- getLogger + dflags' <- checkNewDynFlags logger dflags dflags_prev <- getProgramDynFlags let changed = packageFlagsChanged dflags_prev dflags' if changed then do hsc_env <- getSession - (dbs,unit_state,home_unit) <- liftIO $ initUnits dflags' (hsc_unit_dbs hsc_env) + (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags' (hsc_unit_dbs hsc_env) let unit_env = UnitEnv { ue_platform = targetPlatform dflags' , ue_namever = ghcNameVersion dflags' @@ -759,8 +762,9 @@ getProgramDynFlags = getSessionDynFlags -- 'unitState' into the interactive @DynFlags@. setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - dflags'' <- checkNewInteractiveDynFlags dflags' + logger <- getLogger + dflags' <- checkNewDynFlags logger dflags + dflags'' <- checkNewInteractiveDynFlags logger dflags' modifySessionM $ \hsc_env0 -> do let ic0 = hsc_IC hsc_env0 @@ -783,12 +787,15 @@ getInteractiveDynFlags :: GhcMonad m => m DynFlags getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) -parseDynamicFlags :: MonadIO m => - DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) -parseDynamicFlags dflags cmdline = do +parseDynamicFlags + :: MonadIO m + => Logger + -> DynFlags + -> [Located String] + -> m (DynFlags, [Located String], [Warn]) +parseDynamicFlags logger dflags cmdline = do (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline - dflags2 <- liftIO $ interpretPackageEnv dflags1 + dflags2 <- liftIO $ interpretPackageEnv logger dflags1 return (dflags2, leftovers, warns) -- | Parse command line arguments that look like files. @@ -877,19 +884,19 @@ normalise_hyp fp -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible). -checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewDynFlags dflags = do +checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +checkNewDynFlags logger dflags = do -- See Note [DynFlags consistency] let (dflags', warnings) = makeDynFlagsConsistent dflags - liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings) + liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings) return dflags' -checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewInteractiveDynFlags dflags0 = do +checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +checkNewInteractiveDynFlags logger dflags0 = do -- We currently don't support use of StaticPointers in expressions entered on -- the REPL. See #12356. if xopt LangExt.StaticPointers dflags0 - then do liftIO $ printOrThrowWarnings dflags0 $ listToBag + then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag [mkPlainWarnMsg interactiveSrcSpan $ text "StaticPointers is not supported in GHCi interactive expressions."] return $ xopt_unset dflags0 LangExt.StaticPointers @@ -1799,8 +1806,8 @@ parser str dflags filename = -- > id1 -- > id2 -- -interpretPackageEnv :: DynFlags -> IO DynFlags -interpretPackageEnv dflags = do +interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags +interpretPackageEnv logger dflags = do mPkgEnv <- runMaybeT $ msum $ [ getCmdLineArg >>= \env -> msum [ probeNullEnv env @@ -1828,7 +1835,7 @@ interpretPackageEnv dflags = do return dflags Just envfile -> do content <- readFile envfile - compilationProgressMsg dflags (text "Loaded package environment from " <> text envfile) + compilationProgressMsg logger dflags (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 fa7602057f..9298df2544 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -52,6 +52,7 @@ import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic import GHC.Types.Unique.Supply +import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable @@ -68,14 +69,14 @@ mkEmptyContInfoTable info_lbl , cit_srt = Nothing , cit_clo = Nothing } -cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a +cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a) -cmmToRawCmm dflags cmms +cmmToRawCmm logger dflags cmms = do { uniqs <- mkSplitUniqSupply 'i' ; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl]) do_one uniqs cmm = -- NB. strictness fixes a space leak. DO NOT REMOVE. - withTimingSilent dflags (text "Cmm -> Raw Cmm") + withTimingSilent logger dflags (text "Cmm -> Raw Cmm") forceRes $ case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of (b,uniqs') -> return (uniqs',b) diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 59dc19ba80..b508b5a265 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -24,6 +24,7 @@ import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Driver.Backend import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Driver.Env import Control.Monad import GHC.Utils.Outputable @@ -41,26 +42,24 @@ cmmPipeline -> CmmGroup -- Input C-- with Procedures -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $ - do let dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - - tops <- {-# SCC "tops" #-} mapM (cpsTop dflags) prog +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 (procs, data_) = partitionEithers tops (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_ - dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) + let platform = targetPlatform dflags + dumpWith logger dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) - where forceRes (info, group) = - info `seq` foldr (\decl r -> decl `seq` r) () group - - dflags = hsc_dflags hsc_env -cpsTop :: DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) -cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p)) -cpsTop dflags proc = +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 = do ----------- Control-flow optimisations ---------------------------------- @@ -97,7 +96,7 @@ cpsTop dflags proc = then do pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ minimalProcPointSet platform call_pps g - dumpWith dflags Opt_D_dump_cmm_proc "Proc points" + dumpWith logger dflags Opt_D_dump_cmm_proc "Proc points" FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g) return pp else @@ -118,14 +117,14 @@ cpsTop dflags proc = ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g - dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) + dumpWith logger dflags 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 dflags Opt_D_dump_cmm_procmap "procpoint map" + dumpWith logger dflags Opt_D_dump_cmm_procmap "procpoint map" FormatCMM (ppr pp_map) g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ splitAtProcPoints platform l call_pps proc_points pp_map @@ -153,10 +152,10 @@ cpsTop dflags proc = return (Left (cafEnv, g)) where platform = targetPlatform dflags - dump = dumpGraph dflags + dump = dumpGraph logger dflags dumps flag name - = mapM_ (dumpWith dflags flag name FormatCMM . pdoc platform) + = mapM_ (dumpWith logger dflags flag name FormatCMM . pdoc platform) condPass flag pass g dumpflag dumpname = if gopt flag dflags @@ -349,25 +348,24 @@ runUniqSM m = do return (initUs_ us m) -dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () -dumpGraph dflags flag name g = do +dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph logger dflags flag name g = do when (gopt Opt_DoCmmLinting dflags) $ do_lint g - dumpWith dflags flag name FormatCMM (pdoc platform g) + dumpWith logger dflags flag name FormatCMM (pdoc platform g) where platform = targetPlatform dflags do_lint g = case cmmLintGraph platform g of - Just err -> do { fatalErrorMsg dflags err - ; ghcExit dflags 1 + Just err -> do { fatalErrorMsg logger dflags err + ; ghcExit logger dflags 1 } Nothing -> return () -dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -dumpWith dflags flag txt fmt sdoc = do - dumpIfSet_dyn dflags flag txt fmt sdoc +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)) $ -- 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) - $ dumpAction dflags (mkDumpStyle alwaysQualify) - (dumpOptionsFromFlag flag) txt fmt sdoc - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc + $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) flag txt fmt sdoc + dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index daf75a1720..d716686687 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -128,6 +128,7 @@ import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Misc +import GHC.Utils.Logger import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle @@ -148,15 +149,15 @@ import Control.Monad import System.IO -------------------- -nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply +nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen dflags this_mod modLoc h us cmms +nativeCodeGen logger dflags this_mod modLoc h us cmms = let config = initNCGConfig dflags this_mod platform = ncgPlatform config nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a - nCG' ncgImpl = nativeCodeGen' dflags config modLoc ncgImpl h us cmms + nCG' ncgImpl = nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms in case platformArch platform of ArchX86 -> nCG' (X86.ncgX86 config) ArchX86_64 -> nCG' (X86.ncgX86_64 config) @@ -219,7 +220,8 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". -} nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -227,34 +229,35 @@ nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instructio -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen' dflags config modLoc ncgImpl h us cmms +nativeCodeGen' logger dflags 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 dflags config modLoc ncgImpl bufh us + (ngs, us', a) <- cmmNativeGenStream logger dflags config modLoc ncgImpl bufh us cmms ngs0 - _ <- finishNativeGen dflags config modLoc bufh us' ngs + _ <- finishNativeGen logger dflags config modLoc bufh us' ngs return a finishNativeGen :: Instruction instr - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> BufHandle -> UniqSupply -> NativeGenAcc statics instr -> IO UniqSupply -finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs - = withTimingSilent dflags (text "NCG") (`seq` ()) $ do +finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs + = withTimingSilent logger dflags (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 dflags config bufh dwarf + emitNativeCode logger dflags config bufh dwarf return us' bFlush bufh @@ -271,7 +274,7 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs dump_stats (Color.pprStats stats graphGlobal) let platform = ncgPlatform config - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_conflicts "Register conflict graph" FormatText $ Color.dotGraph @@ -293,12 +296,13 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs $ makeImportsDoc config (concat (ngs_imports ngs)) return us' where - dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify) - (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" + dump_stats = putDumpMsg logger dflags (mkDumpStyle alwaysQualify) + Opt_D_dump_asm_stats "NCG stats" FormatText cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -308,7 +312,7 @@ cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instru -> NativeGenAcc statics instr -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs +cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs = do r <- Stream.runStream cmm_stream case r of Left a -> @@ -321,7 +325,7 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs a) Right (cmms, cmm_stream') -> do (us', ngs'') <- - withTimingSilent + withTimingSilent logger dflags ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do -- Generate debug information @@ -330,22 +334,22 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs dbgMap = debugToMap ndbgs -- Generate native code - (ngs',us') <- cmmNativeGens dflags config modLoc ncgImpl h - dbgMap us cmms ngs 0 + (ngs',us') <- cmmNativeGens logger dflags 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 unless (null ldbgs) $ - dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText + dumpIfSet_dyn logger dflags Opt_D_dump_debug "Debug Infos" FormatText (vcat $ map (pdoc platform) ldbgs) -- Accumulate debug information for emission in finishNativeGen. let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] } return (us', ngs'') - cmmNativeGenStream dflags config modLoc ncgImpl h us' + cmmNativeGenStream logger dflags config modLoc ncgImpl h us' cmm_stream' ngs'' where ncglabel = text "NCG" @@ -354,7 +358,8 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs -- cmmNativeGens :: forall statics instr jumpDest. (OutputableP Platform statics, Outputable jumpDest, Instruction instr) - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -366,7 +371,7 @@ cmmNativeGens :: forall statics instr jumpDest. -> Int -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go +cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go where go :: UniqSupply -> [RawCmmDecl] -> NativeGenAcc statics instr -> Int @@ -379,7 +384,7 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go let fileIds = ngs_dwarfFiles ngs (us', fileIds', native, imports, colorStats, linearStats, unwinds) <- {-# SCC "cmmNativeGen" #-} - cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap + cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count -- Generate .file directives for every new file that has been @@ -391,7 +396,7 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go pprDecl (f,n) = text "\t.file " <> ppr n <+> pprFilePathString (unpackFS f) - emitNativeCode dflags config h $ vcat $ + emitNativeCode logger dflags config h $ vcat $ map pprDecl newFileIds ++ map (pprNatCmmDecl ncgImpl) native @@ -416,14 +421,14 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go go us' cmms ngs' (count + 1) -emitNativeCode :: DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO () -emitNativeCode dflags config h sdoc = do +emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO () +emitNativeCode logger dflags config h sdoc = do let ctx = ncgAsmContext config {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc -- dump native code - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm "Asm code" FormatASM sdoc @@ -432,7 +437,8 @@ emitNativeCode dflags config h sdoc = do -- Global conflict graph and NGC stats cmmNativeGen :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) - => DynFlags + => Logger + -> DynFlags -> ModLocation -> NcgImpl statics instr jumpDest -> UniqSupply @@ -449,7 +455,7 @@ cmmNativeGen , LabelMap [UnwindPoint] -- unwinding information for blocks ) -cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count +cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count = do let config = ncgConfig ncgImpl let platform = ncgPlatform config @@ -469,7 +475,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count {-# SCC "cmmToCmm" #-} cmmToCmm config fixed_cmm - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM (pprCmmGroup platform [opt_cmm]) @@ -483,11 +489,11 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count (cmmTopCodeGen ncgImpl) fileIds dbgMap opt_cmm cmmCfg - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_native "Native code" FormatASM (vcat $ map (pprNatCmmDecl ncgImpl) native) - maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name + maybeDumpCfg logger dflags (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 @@ -500,7 +506,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count initUs usGen $ mapM (cmmTopLiveness livenessCfg platform) native - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_liveness "Liveness annotations added" FormatCMM (vcat $ map (pprLiveCmmDecl platform) withLiveness) @@ -540,12 +546,12 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count -- dump out what happened during register allocation - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" FormatText (vcat $ map (\(stage, stats) @@ -584,7 +590,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count $ liftM unzip3 $ mapM reg_alloc withLiveness - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) @@ -619,7 +625,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count {-# SCC "generateJumpTables" #-} generateJumpTables ncgImpl alloced - when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags + when (not $ null nativeCfgWeights) $ dumpIfSet_dyn logger dflags Opt_D_dump_cfg_weights "CFG Update information" FormatText ( text "stack:" <+> ppr stack_updt_blks $$ @@ -634,7 +640,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count optimizedCFG = optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG - maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name + maybeDumpCfg logger dflags optimizedCFG "CFG Weights - Final" proc_name --TODO: Partially check validity of the cfg. let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks @@ -675,7 +681,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count ncgExpandTop ncgImpl branchOpt --ncgExpandTop ncgImpl sequenced - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) expanded) @@ -697,12 +703,12 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count , ppr_raStatsLinear , unwinds ) -maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO () -maybeDumpCfg _dflags Nothing _ _ = return () -maybeDumpCfg dflags (Just cfg) msg proc_name +maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO () +maybeDumpCfg _logger _dflags Nothing _ _ = return () +maybeDumpCfg logger dflags (Just cfg) msg proc_name | null cfg = return () | otherwise - = dumpIfSet_dyn + = dumpIfSet_dyn logger dflags Opt_D_dump_cfg_weights msg FormatText (proc_name <> char ':' $$ pprEdgeWeights cfg) diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index c9b50c731e..3cf7b50ceb 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -35,6 +35,7 @@ import GHC.Utils.Error import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.SysTools ( figureLlvmVersion ) import qualified GHC.Data.Stream as Stream @@ -45,37 +46,37 @@ import System.IO -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator -- -llvmCodeGen :: DynFlags -> Handle +llvmCodeGen :: Logger -> DynFlags -> Handle -> Stream.Stream IO RawCmmGroup a -> IO a -llvmCodeGen dflags h cmm_stream - = withTiming dflags (text "LLVM CodeGen") (const ()) $ do +llvmCodeGen logger dflags h cmm_stream + = withTiming logger dflags (text "LLVM CodeGen") (const ()) $ do bufh <- newBufHandle h -- Pass header - showPass dflags "LLVM CodeGen" + showPass logger dflags "LLVM CodeGen" -- get llvm version, cache for later use - mb_ver <- figureLlvmVersion dflags + mb_ver <- figureLlvmVersion logger dflags -- warn if unsupported forM_ mb_ver $ \ver -> do - debugTraceMsg dflags 2 + debugTraceMsg logger dflags 2 (text "Using LLVM version:" <+> text (llvmVersionStr ver)) let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $ + when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger dflags $ "You are using an unsupported version of LLVM!" $$ "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..." let isS390X = platformArch (targetPlatform dflags) == ArchS390X let major_ver = head . llvmVersionList $ ver - when (isS390X && major_ver < 10 && doWarn) $ putMsg dflags $ + when (isS390X && major_ver < 10 && doWarn) $ putMsg logger dflags $ "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> "You are using LLVM version: " <> text (llvmVersionStr ver) -- run code generation - a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $ + a <- runLlvm logger dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $ llvmCodeGen' dflags (liftStream cmm_stream) bFlush bufh diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index d68b5d5c8e..84c82ef873 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -61,7 +61,7 @@ import GHC.Types.Unique import GHC.Utils.BufHandle ( BufHandle ) import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import GHC.Utils.Error +import GHC.Utils.Logger import qualified GHC.Data.Stream as Stream import Data.Maybe (fromJust) @@ -302,6 +302,7 @@ data LlvmEnv = LlvmEnv { envVersion :: LlvmVersion -- ^ LLVM version , envOpts :: LlvmOpts -- ^ LLVM backend options , envDynFlags :: DynFlags -- ^ Dynamic flags + , envLogger :: !Logger -- ^ Logger , envOutput :: BufHandle -- ^ Output buffer , envMask :: !Char -- ^ Mask for creating unique values , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs @@ -332,6 +333,10 @@ instance Monad LlvmM where instance HasDynFlags LlvmM where getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) +instance HasLogger LlvmM where + getLogger = LlvmM $ \env -> return (envLogger env, env) + + -- | Get target platform getPlatform :: LlvmM Platform getPlatform = llvmOptsPlatform <$> getLlvmOpts @@ -355,8 +360,8 @@ liftIO m = LlvmM $ \env -> do x <- m return (x, env) -- | Get initial Llvm environment. -runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a -runLlvm dflags ver out m = do +runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a +runLlvm logger dflags ver out m = do (a, _) <- runLlvmM m env return a where env = LlvmEnv { envFunMap = emptyUFM @@ -367,6 +372,7 @@ runLlvm dflags ver out m = do , envVersion = ver , envOpts = initLlvmOpts dflags , envDynFlags = dflags + , envLogger = logger , envOutput = out , envMask = 'n' , envFreshMeta = MetaId 0 @@ -426,7 +432,8 @@ getLlvmVer = getEnv envVersion dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () dumpIfSetLlvm flag hdr fmt doc = do dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc + logger <- getLogger + liftIO $ dumpIfSet_dyn logger dflags 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 0436dbcf07..805f1b8074 100644 --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -17,15 +17,16 @@ 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 Control.Exception import qualified Data.ByteString.Char8 as B import System.IO -- | Read in assembly file and process -llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () -llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} - withTiming dflags (text "LLVM Mangler") id $ +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 diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index f1720725a6..382851a1e5 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -65,8 +65,10 @@ import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify import GHC.Types.Basic -import GHC.Utils.Error hiding ( dumpIfSet ) +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.Data.List.SetOps import GHC.Builtin.Names import GHC.Utils.Outputable as Outputable @@ -288,21 +290,23 @@ endPassIO :: HscEnv -> PrintUnqualified -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too endPassIO hsc_env print_unqual pass binds rules - = do { dumpPassResult dflags print_unqual mb_flag + = do { dumpPassResult logger dflags print_unqual mb_flag (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 _ -> Nothing -dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () -dumpIfSet dflags dump_me pass extra_info doc - = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc +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 :: DynFlags +dumpPassResult :: Logger + -> DynFlags -> PrintUnqualified -> Maybe DumpFlag -- Just df => show details in a file whose -- name is specified by df @@ -310,16 +314,16 @@ dumpPassResult :: DynFlags -> SDoc -- Extra info to appear after header -> CoreProgram -> [CoreRule] -> IO () -dumpPassResult dflags unqual mb_flag hdr extra_info binds rules +dumpPassResult logger dflags unqual mb_flag hdr extra_info binds rules = do { forM_ mb_flag $ \flag -> do let sty = mkDumpStyle unqual - dumpAction dflags sty (dumpOptionsFromFlag flag) + putDumpMsg logger dflags sty flag (showSDoc dflags 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 dflags 2 size_doc + ; Err.debugTraceMsg logger dflags 2 size_doc } where @@ -375,35 +379,37 @@ lintPassResult hsc_env pass binds = return () | otherwise = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds - ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults dflags (showLintWarnings pass) (ppr pass) + ; Err.showPass logger dflags ("Core Linted result of " ++ showPpr dflags pass) + ; displayLintResults logger dflags (showLintWarnings pass) (ppr pass) (pprCoreBindings binds) warns_and_errs } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env -displayLintResults :: DynFlags +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 dflags display_warnings pp_what pp_pgm (warns, errs) +displayLintResults logger dflags display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag errs) - = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan + = do { putLogMsg logger dflags NoReason Err.SevDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs , text "*** Offending Program ***" , pp_pgm , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } + ; Err.ghcExit logger dflags 1 } | not (isEmptyBag warns) , not (hasNoDebugOutput dflags) , display_warnings -- If the Core linter encounters an error, output to stderr instead of -- stdout (#13342) - = putLogMsg dflags NoReason Err.SevInfo noSrcSpan + = putLogMsg logger dflags NoReason Err.SevInfo noSrcSpan $ withPprStyle defaultDumpStyle (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) @@ -426,11 +432,12 @@ lintInteractiveExpr what hsc_env expr | not (gopt Opt_DoCoreLinting dflags) = return () | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr - = displayLintResults dflags False what (pprCoreExpr expr) (emptyBag, err) + = displayLintResults logger dflags False what (pprCoreExpr expr) (emptyBag, err) | otherwise = return () where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env interactiveInScope :: HscEnv -> [Var] -- In GHCi we may lint expressions, or bindings arising from 'deriving' @@ -2314,12 +2321,13 @@ lintCoercion (HoleCo h) ************************************************************************ -} -lintAxioms :: DynFlags +lintAxioms :: Logger + -> DynFlags -> SDoc -- ^ The source of the linted axioms -> [CoAxiom Branched] -> IO () -lintAxioms dflags what axioms = - displayLintResults dflags True what (vcat $ map pprCoAxiom axioms) $ +lintAxioms logger dflags what axioms = + displayLintResults logger dflags True what (vcat $ map pprCoAxiom axioms) $ initL dflags (defaultLintFlags dflags) [] $ do { mapM_ lint_axiom axioms ; let axiom_groups = groupWith coAxiomTyCon axioms @@ -3265,16 +3273,17 @@ lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts lintAnnots pname pass guts = do -- Run the pass as we normally would dflags <- getDynFlags + logger <- getLogger when (gopt Opt_DoAnnotationLinting dflags) $ - liftIO $ Err.showPass dflags "Annotation linting - first run" + liftIO $ Err.showPass logger dflags "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 dflags "Annotation linting - second run" + liftIO $ Err.showPass logger dflags "Annotation linting - second run" nguts' <- withoutAnnots pass guts -- Finally compare the resulting bindings - liftIO $ Err.showPass dflags "Annotation linting - comparison" + liftIO $ Err.showPass logger dflags "Annotation linting - comparison" let binds = flattenBinds $ mg_binds nguts binds' = flattenBinds $ mg_binds nguts' (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index e47d4007de..81aa9f94fe 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.FamInstEnv import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc -import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) ) import GHC.Data.Maybe ( isJust, isNothing ) import Control.Monad ( guard ) @@ -104,11 +104,11 @@ So currently we have -- * Analysing programs -- -cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -cprAnalProgram dflags fam_envs binds = do +cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram +cprAnalProgram logger dflags fam_envs binds = do let env = emptyAnalEnv fam_envs let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds - dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ + dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ dumpIdInfoOfProgram (ppr . cprInfo) 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/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index fc65ae77f5..26a7c261bf 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.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Utils.Logger ( dumpIfSet_dyn, DumpFormat (..), Logger ) import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, isJoinId, isJoinId_maybe ) import GHC.Core.Opt.SetLevels @@ -163,24 +163,25 @@ Without floating, we're stuck with three loops instead of one. ************************************************************************ -} -floatOutwards :: FloatOutSwitches +floatOutwards :: Logger + -> FloatOutSwitches -> DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram -floatOutwards float_sws dflags us pgm +floatOutwards logger float_sws dflags us pgm = do { let { annotated_w_levels = setLevels float_sws pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) } ; - dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" + dumpIfSet_dyn logger dflags Opt_D_verbose_core2core "Levels added:" FormatCore (vcat (map ppr annotated_w_levels)); let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; - dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" + dumpIfSet_dyn logger dflags 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 7fa1c4f871..e7941b82d1 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -64,7 +64,8 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable -import GHC.Utils.Error ( Severity(..), DumpFormat (..), dumpAction, dumpOptionsFromFlag ) +import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger ) +import GHC.Utils.Error ( Severity(..) ) import GHC.Utils.Monad import GHC.Data.FastString @@ -172,6 +173,7 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_logger :: !Logger , sm_dflags :: DynFlags -- Just for convenient non-monadic access; we don't override these. -- @@ -180,9 +182,7 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad -- - Opt_DictsCheap and Opt_PedanticBottoms general flags -- - rules options (initRuleOpts) -- - verbose_core2core, dump_inlinings, dump_rule_rewrites/firings - -- - traceAction, dumpAction -- - inlineCheck - -- - touchDumpFile (generatedDumps, etc.) } instance Outputable SimplMode where @@ -723,6 +723,9 @@ getUniqMask = read cr_uniq_mask instance HasDynFlags CoreM where getDynFlags = fmap hsc_dflags getHscEnv +instance HasLogger CoreM where + getLogger = fmap hsc_logger getHscEnv + instance HasModule CoreM where getModule = read cr_module @@ -789,19 +792,20 @@ we aren't using annotations heavily. -} msg :: Severity -> WarnReason -> SDoc -> CoreM () -msg sev reason doc - = do { dflags <- getDynFlags - ; loc <- getSrcSpanM - ; unqual <- getPrintUnqualified - ; let sty = case sev of - SevError -> err_sty - SevWarning -> err_sty - SevDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle unqual - user_sty = mkUserStyle unqual AllTheWay - dump_sty = mkDumpStyle unqual - ; liftIO $ putLogMsg dflags reason sev loc (withPprStyle sty doc) } +msg sev reason doc = do + dflags <- getDynFlags + logger <- getLogger + loc <- getSrcSpanM + unqual <- getPrintUnqualified + let sty = case sev of + SevError -> err_sty + SevWarning -> err_sty + SevDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle unqual + user_sty = mkUserStyle unqual AllTheWay + dump_sty = mkDumpStyle unqual + liftIO $ putLogMsg logger dflags reason sev loc (withPprStyle sty doc) -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -840,9 +844,10 @@ debugTraceMsg = msg SevDump NoReason -- | 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 - ; unqual <- getPrintUnqualified - ; when (dopt flag dflags) $ liftIO $ do - let sty = mkDumpStyle unqual - dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc } +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 6a21063f22..c85b39754e 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -50,7 +50,8 @@ import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv import qualified GHC.Utils.Error as Err -import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) ) +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Logger as Logger import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -88,7 +89,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_loc = loc , mg_deps = deps , mg_rdr_env = rdr_env }) - = do { let builtin_passes = getCoreToDo dflags + = do { let builtin_passes = getCoreToDo logger dflags orph_mods = mkModuleSet (mod : dep_orphs deps) uniq_mask = 's' ; @@ -100,13 +101,14 @@ core2core hsc_env guts@(ModGuts { mg_module = mod builtin_passes ; runCorePasses all_passes guts } - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats + ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" FormatText (pprSimplCount stats) ; return guts2 } where + logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env home_pkg_rules = hptRules hsc_env (dep_mods deps) hpt_rule_base = mkRuleBase home_pkg_rules @@ -125,8 +127,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod ************************************************************************ -} -getCoreToDo :: DynFlags -> [CoreToDo] -getCoreToDo dflags +getCoreToDo :: Logger -> DynFlags -> [CoreToDo] +getCoreToDo logger dflags = flatten_todos core_todo where opt_level = optLevel dflags @@ -162,6 +164,7 @@ getCoreToDo dflags base_mode = SimplMode { sm_phase = panic "base_mode" , sm_names = [] , sm_dflags = dflags + , sm_logger = logger , sm_uf_opts = unfoldingOpts dflags , sm_rules = rules_on , sm_eta_expand = eta_expand_on @@ -462,70 +465,76 @@ runCorePasses passes guts where do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts - do_pass guts pass = - withTimingD (ppr pass <+> brackets (ppr mod)) + do_pass guts pass = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger dflags (ppr pass <+> brackets (ppr mod)) (const ()) $ do - { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts - ; endPass pass (mg_binds guts') (mg_rules guts') - ; return guts' } + guts' <- lintAnnots (ppr pass) (doCorePass pass) guts + endPass pass (mg_binds guts') (mg_rules guts') + return guts' mod = mg_module guts doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts -doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} - simplifyPgm pass +doCorePass pass guts = do + logger <- getLogger + case pass of + CoreDoSimplify {} -> {-# SCC "Simplify" #-} + simplifyPgm pass guts -doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - doPass cseProgram + CoreCSE -> {-# SCC "CommonSubExpr" #-} + doPass cseProgram guts -doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} - doPassD liberateCase + CoreLiberateCase -> {-# SCC "LiberateCase" #-} + doPassD liberateCase guts -doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - floatInwards + CoreDoFloatInwards -> {-# SCC "FloatInwards" #-} + floatInwards guts -doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} - doPassDUM (floatOutwards f) + CoreDoFloatOutwards f -> {-# SCC "FloatOutwards" #-} + doPassDUM (floatOutwards logger f) guts -doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} - doPassU doStaticArgs + CoreDoStaticArgs -> {-# SCC "StaticArgs" #-} + doPassU doStaticArgs guts -doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} - doPassD callArityAnalProgram + CoreDoCallArity -> {-# SCC "CallArity" #-} + doPassD callArityAnalProgram guts -doCorePass CoreDoExitify = {-# SCC "Exitify" #-} - doPass exitifyProgram + CoreDoExitify -> {-# SCC "Exitify" #-} + doPass exitifyProgram guts -doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-} - doPassDFRM dmdAnal + CoreDoDemand -> {-# SCC "DmdAnal" #-} + doPassDFRM (dmdAnal logger) guts -doCorePass CoreDoCpr = {-# SCC "CprAnal" #-} - doPassDFM cprAnalProgram + CoreDoCpr -> {-# SCC "CprAnal" #-} + doPassDFM (cprAnalProgram logger) guts -doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} - doPassDFU wwTopBinds + CoreDoWorkerWrapper -> {-# SCC "WorkWrap" #-} + doPassDFU wwTopBinds guts -doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - specProgram + CoreDoSpecialising -> {-# SCC "Specialise" #-} + specProgram guts -doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} - specConstrProgram + CoreDoSpecConstr -> {-# SCC "SpecConstr" #-} + specConstrProgram guts -doCorePass CoreAddCallerCcs = {-# SCC "AddCallerCcs" #-} - addCallerCostCentres + CoreAddCallerCcs -> {-# SCC "AddCallerCcs" #-} + addCallerCostCentres guts -doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat -doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = runCorePasses passes + CoreDoPrintCore -> observe (printCore logger) guts -doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass + CoreDoRuleCheck phase pat -> ruleCheckPass phase pat guts + CoreDoNothing -> return guts + CoreDoPasses passes -> runCorePasses passes guts -doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreTidy = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CorePrep = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass) + CoreDoPluginPass _ p -> {-# SCC "Plugin" #-} p guts + + CoreDesugar -> pprPanic "doCorePass" (ppr pass) + CoreDesugarOpt -> pprPanic "doCorePass" (ppr pass) + CoreTidy -> pprPanic "doCorePass" (ppr pass) + CorePrep -> pprPanic "doCorePass" (ppr pass) + CoreOccurAnal -> pprPanic "doCorePass" (ppr pass) {- ************************************************************************ @@ -535,25 +544,26 @@ doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass) ************************************************************************ -} -printCore :: DynFlags -> CoreProgram -> IO () -printCore dflags binds - = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) +printCore :: Logger -> DynFlags -> CoreProgram -> IO () +printCore logger dflags binds + = Logger.dumpIfSet logger dflags True "Print Core" (pprCoreBindings binds) ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheckPass current_phase pat guts = - withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) +ruleCheckPass current_phase pat guts = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger dflags (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) (const ()) $ do - { rb <- getRuleBase - ; dflags <- getDynFlags - ; vis_orphs <- getVisibleOrphanMods - ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn - ++ (mg_rules guts) - ; let ropts = initRuleOpts dflags - ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan - $ withPprStyle defaultDumpStyle - (ruleCheckProgram ropts current_phase pat - rule_fn (mg_binds guts)) - ; return guts } + 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 NoReason Err.SevDump noSrcSpan + $ withPprStyle defaultDumpStyle + (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 @@ -626,23 +636,23 @@ 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 dflags (text "Simplify [expr]") (const ()) $ + = withTiming logger dflags (text "Simplify [expr]") (const ()) $ do { eps <- hscEPS hsc_env ; ; let rule_env = mkRuleEnv (eps_rule_base eps) [] fi_env = ( eps_fam_inst_env eps , extendFamInstEnvList emptyFamInstEnv $ snd $ ic_instances $ hsc_IC hsc_env ) - simpl_env = simplEnvForGHCi dflags + simpl_env = simplEnvForGHCi logger dflags ; let sz = exprSize expr - ; (expr', counts) <- initSmpl dflags rule_env fi_env sz $ + ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $ simplExprGently simpl_env expr - ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) + ; Logger.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics" (pprSimplCount counts) - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl "Simplified expression" FormatCore (pprCoreExpr expr') @@ -650,6 +660,7 @@ simplifyExpr hsc_env expr } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- Simplifies an expression @@ -704,7 +715,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) = do { (termination_msg, it_count, counts_out, guts') <- do_iteration 1 [] binds rules - ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && + ; Logger.dumpIfSet logger dflags (dopt Opt_D_verbose_core2core dflags && dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count @@ -716,6 +727,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env simpl_env = mkSimplEnv mode active_rule = activeRule mode @@ -755,7 +767,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) occurAnalysePgm this_mod active_unf active_rule rules binds } ; - Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + Logger.dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings tagged_binds); @@ -773,7 +785,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- Simplify the program ((binds1, rules1), counts1) <- - initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $ + initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $ do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds @@ -803,7 +815,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; + dump_end_iteration logger dflags print_unqual iteration_no counts1 binds2 rules1 ; lintPassResult hsc_env pass binds2 ; -- Loop @@ -821,10 +833,10 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO" ------------------- -dump_end_iteration :: DynFlags -> PrintUnqualified -> Int +dump_end_iteration :: Logger -> DynFlags -> PrintUnqualified -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration dflags print_unqual iteration_no counts binds rules - = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules +dump_end_iteration logger dflags print_unqual iteration_no counts binds rules + = dumpPassResult logger dflags 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 @@ -1095,13 +1107,13 @@ transferIdInfo exported_id local_id -dmdAnal :: DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram -dmdAnal dflags fam_envs rules binds = do +dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram +dmdAnal logger dflags fam_envs rules binds = do let !opts = DmdAnalOpts { dmd_strict_dicts = gopt Opt_DictsStrict dflags } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds - Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ + Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) 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 4ca8985f8b..9f98615711 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -57,6 +57,7 @@ import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) import GHC.Types.Basic import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Utils.Logger import GHC.Types.Var ( isTyCoVar ) import GHC.Data.Maybe ( orElse ) import Control.Monad @@ -64,7 +65,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Misc -import GHC.Utils.Error import GHC.Unit.Module ( moduleName, pprModuleName ) import GHC.Core.Multiplicity import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) @@ -267,6 +267,7 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs 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 @@ -274,7 +275,7 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs | not (dopt Opt_D_verbose_core2core dflags) = thing_inside | otherwise - = traceAction dflags ("SimplBind " ++ what) + = putTraceMsg logger dflags ("SimplBind " ++ what) (ppr old_bndr) thing_inside -------------------------- @@ -1882,7 +1883,7 @@ simplIdF env var cont completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) completeCall env var cont - | Just expr <- callSiteInline dflags case_depth var active_unf + | Just expr <- callSiteInline logger dflags case_depth var active_unf lone_variable arg_infos interesting_cont -- Inline the variable's RHS = do { checkedTick (UnfoldingDone var) @@ -1899,15 +1900,16 @@ completeCall env var cont where dflags = seDynFlags env case_depth = seCaseDepth env + logger = seLogger env (lone_variable, arg_infos, call_cont) = contArgs cont n_val_args = length arg_infos interesting_cont = interestingCallContext env call_cont active_unf = activeUnfolding (getMode env) var log_inlining doc - = liftIO $ dumpAction dflags + = liftIO $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) - (dumpOptionsFromFlag Opt_D_dump_inlinings) + Opt_D_dump_inlinings "" FormatText doc dump_inline unfolding cont @@ -2170,6 +2172,7 @@ tryRules env rules fn args call_cont where ropts = initRuleOpts dflags dflags = seDynFlags env + logger = seLogger env zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] printRuleModule rule @@ -2198,11 +2201,11 @@ tryRules env rules fn args call_cont nodump | dopt Opt_D_dump_rule_rewrites dflags = liftIO $ - touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) + touchDumpFile logger dflags Opt_D_dump_rule_rewrites | dopt Opt_D_dump_rule_firings dflags = liftIO $ - touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) + touchDumpFile logger dflags Opt_D_dump_rule_firings | otherwise = return () @@ -2210,7 +2213,7 @@ tryRules env rules fn args call_cont log_rule dflags flag hdr details = liftIO $ do let sty = mkDumpStyle alwaysQualify - dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ + putDumpMsg logger dflags sty flag "" FormatText $ sep [text hdr, nest 4 details] trySeqRules :: SimplEnv diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 0d4e06f9c2..1bfa38e481 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -8,7 +8,7 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode - setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, + setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract @@ -71,6 +71,7 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Unique.FM ( pprUniqFM ) import Data.List (mapAccumL) @@ -312,6 +313,10 @@ getMode env = seMode env seDynFlags :: SimplEnv -> DynFlags seDynFlags env = sm_dflags (seMode env) +seLogger :: SimplEnv -> Logger +seLogger env = sm_logger (seMode env) + + seUnfoldingOpts :: SimplEnv -> UnfoldingOpts seUnfoldingOpts env = sm_uf_opts (seMode env) diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index d1e27f9fca..9f95297924 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -39,7 +39,7 @@ import GHC.Core.Opt.Monad import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Monad -import GHC.Utils.Error as Err +import GHC.Utils.Logger as Logger import GHC.Utils.Misc ( count ) import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) @@ -78,6 +78,7 @@ pattern SM m <- SM' m data SimplTopEnv = STE { st_flags :: DynFlags + , st_logger :: !Logger , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run , st_rules :: RuleEnv , st_fams :: (FamInstEnv, FamInstEnv) @@ -86,19 +87,20 @@ data SimplTopEnv -- ^ Coercion optimiser options } -initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) +initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) -> Int -- Size of the bindings, used to limit -- the number of ticks we allow -> SimplM a -> IO (a, SimplCount) -initSmpl dflags rules fam_envs size m +initSmpl logger dflags rules fam_envs size m = do -- No init count; set to 0 let simplCount = zeroSimplCount dflags (result, count) <- unSM m env simplCount return (result, count) where env = STE { st_flags = dflags + , st_logger = logger , st_rules = rules , st_max_ticks = computeMaxTicks dflags size , st_fams = fam_envs @@ -168,10 +170,11 @@ thenSmpl_ m k traceSmpl :: String -> SDoc -> SimplM () traceSmpl herald doc - = do { dflags <- getDynFlags - ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace" - FormatText - (hang (text herald) 2 doc) } + = do dflags <- getDynFlags + logger <- getLogger + liftIO $ Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_trace "Simpl Trace" + FormatText + (hang (text herald) 2 doc) {-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities] {- @@ -193,6 +196,9 @@ instance MonadUnique SimplM where instance HasDynFlags SimplM where getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc)) +instance HasLogger SimplM where + getLogger = SM (\st_env sc -> return (st_logger st_env, sc)) + instance MonadIO SimplM where liftIO m = SM $ \_ sc -> do x <- m diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 191e72e3b2..51dbc408d0 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -70,6 +70,7 @@ import GHC.Utils.Misc import GHC.Data.OrdList ( isNilOL ) import GHC.Utils.Monad import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Core.Opt.ConstantFold import GHC.Data.FastString ( fsLit ) @@ -858,10 +859,11 @@ GHC.Core.Opt.Monad sm_eta_expand :: Bool -- Whether eta-expansion is enabled -} -simplEnvForGHCi :: DynFlags -> SimplEnv -simplEnvForGHCi dflags +simplEnvForGHCi :: Logger -> DynFlags -> SimplEnv +simplEnvForGHCi logger dflags = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] , sm_phase = InitialPhase + , sm_logger = logger , sm_dflags = dflags , sm_uf_opts = uf_opts , sm_rules = rules_on diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 8a61eec3c7..b8a4dd53d9 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -56,11 +56,11 @@ import GHC.Core.Type import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Data.Bag +import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Types.ForeignCall import GHC.Types.Name -import GHC.Utils.Error import qualified Data.ByteString as BS import Data.List (isPrefixOf) @@ -1052,7 +1052,8 @@ them inlining is to give them a NOINLINE pragma, which we do in StrictAnal.addStrictnessInfoToTopId -} -callSiteInline :: DynFlags +callSiteInline :: Logger + -> DynFlags -> Int -- Case depth -> Id -- The Id -> Bool -- True <=> unfolding is active @@ -1096,7 +1097,7 @@ instance Outputable CallCtxt where ppr DiscArgCtxt = text "DiscArgCtxt" ppr RuleArgCtxt = text "RuleArgCtxt" -callSiteInline dflags !case_depth id active_unfolding lone_variable arg_infos cont_info +callSiteInline logger dflags !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* @@ -1104,22 +1105,22 @@ callSiteInline dflags !case_depth id active_unfolding lone_variable arg_infos co CoreUnfolding { uf_tmpl = unf_template , uf_is_work_free = is_wf , uf_guidance = guidance, uf_expandable = is_exp } - | active_unfolding -> tryUnfolding dflags case_depth id lone_variable + | active_unfolding -> tryUnfolding logger dflags case_depth id lone_variable arg_infos cont_info unf_template is_wf is_exp guidance - | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing + | otherwise -> traceInline logger dflags 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 :: DynFlags -> Id -> String -> SDoc -> a -> a -traceInline dflags inline_id str doc result +traceInline :: Logger -> DynFlags -> Id -> String -> SDoc -> a -> a +traceInline logger dflags 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 = traceAction dflags str doc result + | enable = putTraceMsg logger dflags str doc result | otherwise = result where enable @@ -1227,32 +1228,32 @@ needed on a per-module basis. -} -tryUnfolding :: DynFlags -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt +tryUnfolding :: Logger -> DynFlags -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance -> Maybe CoreExpr -tryUnfolding dflags !case_depth id lone_variable +tryUnfolding logger dflags !case_depth id lone_variable arg_infos cont_info unf_template is_wf is_exp guidance = case guidance of - UnfNever -> traceInline dflags id str (text "UnfNever") Nothing + UnfNever -> traceInline logger dflags 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) -- See Note [INLINE for small functions (3)] - -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template) + -> traceInline logger dflags id str (mk_doc some_benefit empty True) (Just unf_template) | otherwise - -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing + -> traceInline logger dflags 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 dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) | is_wf && some_benefit && small_enough - -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) | otherwise - -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing + -> traceInline logger dflags 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 diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 79604c3639..b1ebac9231 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -47,6 +47,7 @@ import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Var.Set import GHC.Builtin.Types ( unboxedUnitTy ) import GHC.Builtin.Types.Prim @@ -97,7 +98,7 @@ byteCodeGen :: HscEnv -> Maybe ModBreaks -> IO CompiledByteCode byteCodeGen hsc_env this_mod binds tycs mb_modBreaks - = withTiming dflags + = withTiming logger dflags (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do -- Split top-level binds into strings and others. @@ -117,7 +118,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks when (notNull ffis) (panic "GHC.CoreToByteCode.byteCodeGen: missing final emitBc?") - dumpIfSet_dyn dflags Opt_D_dump_BCOs + dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (vcat (intersperse (char ' ') (map ppr proto_bcos))) @@ -137,6 +138,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks return cbc where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env allocateTopStrings :: HscEnv @@ -170,7 +172,7 @@ coreExprToBCOs :: HscEnv -> CoreExpr -> IO UnlinkedBCO coreExprToBCOs hsc_env this_mod expr - = withTiming dflags + = withTiming logger dflags (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do -- create a totally bogus name for the top-level BCO; this @@ -187,11 +189,12 @@ coreExprToBCOs hsc_env this_mod expr when (notNull mallocd) (panic "GHC.CoreToByteCode.coreExprToBCOs: missing final emitBc?") - dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode + dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (ppr proto_bco) assembleOneBCO hsc_env proto_bco where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env -- The regular freeVars function gives more information than is useful to -- us here. We need only the free variables, not everything in an FVAnn. diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 9eae6867ac..3b3921f5e2 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -56,6 +56,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Logger import GHC.Types.Demand import GHC.Types.Var @@ -186,7 +187,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 dflags + withTiming logger dflags (text "CorePrep"<+>brackets (ppr this_mod)) (const ()) $ do us <- mkSplitUniqSupply 's' @@ -211,15 +212,17 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons = return (binds_out, cost_centres) where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr hsc_env expr = do let dflags = hsc_dflags hsc_env - withTiming dflags (text "CorePrep [expr]") (const ()) $ do + let logger = hsc_logger hsc_env + withTiming logger dflags (text "CorePrep [expr]") (const ()) $ do us <- mkSplitUniqSupply 's' initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) + dumpIfSet_dyn logger dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) return new_expr corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs index 850d111818..1ba59130db 100644 --- a/compiler/GHC/Data/IOEnv.hs +++ b/compiler/GHC/Data/IOEnv.hs @@ -48,6 +48,7 @@ import Control.Monad import Control.Monad.Trans.Reader import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import GHC.Utils.Monad +import GHC.Utils.Logger import Control.Applicative (Alternative(..)) import GHC.Exts( oneShot ) @@ -110,6 +111,11 @@ instance ContainsDynFlags env => HasDynFlags (IOEnv env) where getDynFlags = do env <- getEnv return $! extractDynFlags env +instance ContainsLogger env => HasLogger (IOEnv env) where + getLogger = do env <- getEnv + return $! extractLogger env + + instance ContainsModule env => HasModule (IOEnv env) where getModule = do env <- getEnv return $ extractModule env diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 0a1a2b8bf7..5974cded53 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -55,6 +55,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Unit import GHC.Unit.Env @@ -90,6 +91,8 @@ import qualified Data.Set as Set -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc () doBackpack [src_filename] = do + logger <- getLogger + -- Apply options from file to dflags dflags0 <- getDynFlags let dflags1 = dflags0 @@ -98,7 +101,7 @@ doBackpack [src_filename] = do modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) -- Cribbed from: preprocessFile / GHC.Driver.Pipeline liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ handleFlagWarnings dflags warns + liftIO $ handleFlagWarnings logger dflags warns -- TODO: Preprocessing not implemented buf <- liftIO $ hGetStringBuffer src_filename @@ -413,6 +416,7 @@ compileExe lunit = do addUnit :: GhcMonad m => UnitInfo -> m () addUnit u = do hsc_env <- getSession + logger <- getLogger newdbs <- case hsc_unit_dbs hsc_env of Nothing -> panic "addUnit: called too early" Just dbs -> @@ -421,7 +425,7 @@ addUnit u = do , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters - (dbs,unit_state,home_unit) <- liftIO $ initUnits (hsc_dflags hsc_env) (Just newdbs) + (dbs,unit_state,home_unit) <- liftIO $ initUnits logger (hsc_dflags hsc_env) (Just newdbs) let unit_env = UnitEnv { ue_platform = targetPlatform (hsc_dflags hsc_env) , ue_namever = ghcNameVersion (hsc_dflags hsc_env) @@ -473,6 +477,9 @@ data BkpEnv -- TODO: just make a proper new monad for BkpM, rather than use IOEnv instance {-# OVERLAPPING #-} HasDynFlags BkpM where getDynFlags = fmap hsc_dflags getSession +instance {-# OVERLAPPING #-} HasLogger BkpM where + getLogger = fmap hsc_logger getSession + instance GhcMonad BkpM where getSession = do @@ -526,9 +533,9 @@ initBkpM file bkp m = -- | Print a compilation progress message, but with indentation according -- to @level@ (for nested compilation). -backpackProgressMsg :: Int -> DynFlags -> SDoc -> IO () -backpackProgressMsg level dflags msg = - compilationProgressMsg dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr +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 -- | Creates a 'Messager' for Backpack compilation; this is basically @@ -539,9 +546,10 @@ mkBackpackMsg = do level <- getBkpLevel return $ \hsc_env mod_index recomp node -> let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env state = hsc_units hsc_env showMsg msg reason = - backpackProgressMsg level dflags $ pprWithUnitState state $ + backpackProgressMsg level logger dflags $ pprWithUnitState state $ showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node <> reason @@ -575,18 +583,20 @@ backpackStyle = msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do dflags <- getDynFlags + logger <- getLogger level <- getBkpLevel - liftIO . backpackProgressMsg level dflags + liftIO . backpackProgressMsg level logger dflags $ 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 dflags + liftIO . backpackProgressMsg level logger dflags $ pprWithUnitState state $ text "Instantiating " <> withPprStyle backpackStyle (ppr pk) @@ -595,10 +605,11 @@ msgUnitId pk = do 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 dflags + liftIO . backpackProgressMsg level logger dflags $ 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 b251794f1a..fb6d04afbf 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -40,6 +40,7 @@ import GHC.SysTools.FileCleanup import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Unit import GHC.Unit.State @@ -63,7 +64,8 @@ import System.IO ************************************************************************ -} -codeOutput :: DynFlags +codeOutput :: Logger + -> DynFlags -> UnitState -> Module -> FilePath @@ -78,7 +80,7 @@ codeOutput :: DynFlags [(ForeignSrcLang, FilePath)]{-foreign_fps-}, a) -codeOutput dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps +codeOutput logger dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps cmm_stream = do { @@ -88,29 +90,29 @@ codeOutput dflags unit_state this_mod filenm location foreign_stubs foreign_fps then Stream.mapM do_lint cmm_stream else cmm_stream - do_lint cmm = withTimingSilent + do_lint cmm = withTimingSilent logger dflags (text "CmmLint"<+>brackets (ppr this_mod)) (const ()) $ do { case cmmLint (targetPlatform dflags) cmm of - Just err -> do { log_action dflags + Just err -> do { putLogMsg logger dflags NoReason SevDump noSrcSpan $ withPprStyle defaultDumpStyle err - ; ghcExit dflags 1 + ; ghcExit logger dflags 1 } Nothing -> return () ; return cmm } - ; stubs_exist <- outputForeignStubs dflags unit_state this_mod location foreign_stubs + ; stubs_exist <- outputForeignStubs logger dflags unit_state this_mod location foreign_stubs ; a <- case backend dflags of - NCG -> outputAsm dflags this_mod location filenm + NCG -> outputAsm logger dflags this_mod location filenm linted_cmm_stream - ViaC -> outputC dflags filenm linted_cmm_stream pkg_deps - LLVM -> outputLlvm dflags filenm linted_cmm_stream + ViaC -> outputC logger dflags filenm linted_cmm_stream pkg_deps + LLVM -> outputLlvm logger dflags filenm linted_cmm_stream Interpreter -> panic "codeOutput: Interpreter" NoBackend -> panic "codeOutput: NoBackend" ; return (filenm, stubs_exist, foreign_fps, a) @@ -127,13 +129,14 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action ************************************************************************ -} -outputC :: DynFlags +outputC :: Logger + -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> [UnitId] -> IO a -outputC dflags filenm cmm_stream packages = - withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do +outputC logger dflags filenm cmm_stream packages = + withTiming logger dflags (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") @@ -141,7 +144,7 @@ outputC dflags filenm cmm_stream packages = let platform = targetPlatform dflags writeC cmm = do let doc = cmmToC platform cmm - dumpIfSet_dyn dflags Opt_D_dump_c_backend + dumpIfSet_dyn logger dflags Opt_D_dump_c_backend "C backend output" FormatC doc @@ -156,18 +159,19 @@ outputC dflags filenm cmm_stream packages = ************************************************************************ -} -outputAsm :: DynFlags +outputAsm :: Logger + -> DynFlags -> Module -> ModLocation -> FilePath -> Stream IO RawCmmGroup a -> IO a -outputAsm dflags this_mod location filenm cmm_stream = do +outputAsm logger dflags this_mod location filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' - debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + debugTraceMsg logger dflags 4 (text "Outputing asm to" <+> text filenm) {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream + nativeCodeGen logger dflags this_mod location h ncg_uniqs cmm_stream {- ************************************************************************ @@ -177,11 +181,11 @@ outputAsm dflags this_mod location filenm cmm_stream = do ************************************************************************ -} -outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a -outputLlvm dflags filenm cmm_stream = +outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputLlvm logger dflags filenm cmm_stream = {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags f cmm_stream + llvmCodeGen logger dflags f cmm_stream {- ************************************************************************ @@ -191,13 +195,13 @@ outputLlvm dflags filenm cmm_stream = ************************************************************************ -} -outputForeignStubs :: DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs +outputForeignStubs :: Logger -> DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created Maybe FilePath) -- C file created -outputForeignStubs dflags unit_state mod location stubs +outputForeignStubs logger dflags unit_state mod location stubs = do let stub_h = mkStubPaths dflags (moduleName mod) location - stub_c <- newTempName dflags TFL_CurrentModule "c" + stub_c <- newTempName logger dflags TFL_CurrentModule "c" case stubs of NoStubs -> @@ -214,7 +218,7 @@ outputForeignStubs dflags unit_state mod location stubs createDirectoryIfMissing True (takeDirectory stub_h) - dumpIfSet_dyn dflags Opt_D_dump_foreign + dumpIfSet_dyn logger dflags Opt_D_dump_foreign "Foreign export header file" FormatC stub_h_output_d @@ -234,7 +238,7 @@ outputForeignStubs dflags unit_state mod location stubs <- outputForeignStubs_help stub_h stub_h_output_w ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr - dumpIfSet_dyn dflags Opt_D_dump_foreign + dumpIfSet_dyn logger dflags Opt_D_dump_foreign "Foreign export stubs" FormatC stub_c_output_d stub_c_file_exists diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 50c2b5caf6..8d9aa961fb 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -68,7 +68,7 @@ import Data.IORef runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyBag - printOrThrowWarnings (hsc_dflags hsc_env) w + printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w return a -- | Switches in the DynFlags and Plugins from the InteractiveContext @@ -285,4 +285,3 @@ lookupIfaceByModule hpt pit mod mainModIs :: HscEnv -> Module mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env)) - diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs index f4ded1381c..cbd63c27cb 100644 --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -20,6 +20,7 @@ import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Unit.State import GHC.Unit.Types +import GHC.Utils.Logger import {-# SOURCE #-} GHC.Driver.Plugins import Control.Monad ( ap ) @@ -45,6 +46,10 @@ instance MonadIO Hsc where instance HasDynFlags Hsc where getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) +instance HasLogger Hsc where + getLogger = Hsc $ \e w -> return (hsc_logger e, w) + + -- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source -- code (after preprocessing) to either C, assembly or C--. It's also used @@ -147,5 +152,8 @@ data HscEnv -- -- Initialized from the databases cached in 'hsc_unit_dbs' and -- from the DynFlags. + + , hsc_logger :: !Logger + -- ^ Logger } diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 43f3dc859b..d779fc06f8 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -15,6 +15,7 @@ import GHC.Prelude import GHC.Types.SrcLoc import GHC.Types.Error import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle ) +import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine -- | Converts a list of 'WarningMessages' into a tuple where the second element contains only @@ -28,11 +29,11 @@ warningsToMessages dflags = Right warn{ errMsgSeverity = SevError , errMsgReason = ErrReason err_reason } -printBagOfErrors :: RenderableDiagnostic a => DynFlags -> Bag (MsgEnvelope a) -> IO () -printBagOfErrors dflags bag_of_errors +printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO () +printBagOfErrors logger dflags bag_of_errors = sequence_ [ let style = mkErrStyle unqual ctx = initSDocContext dflags style - in putLogMsg dflags reason sev s $ + in putLogMsg logger dflags reason sev s $ withPprStyle style (formatBulleted ctx (renderDiagnostic doc)) | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = doc, @@ -41,8 +42,8 @@ printBagOfErrors dflags bag_of_errors errMsgContext = unqual } <- sortMsgBag (Just dflags) bag_of_errors ] -handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO () -handleFlagWarnings dflags warns = do +handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO () +handleFlagWarnings logger dflags warns = do let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns -- It would be nicer if warns :: [Located SDoc], but that @@ -50,7 +51,7 @@ handleFlagWarnings dflags warns = do bag = listToBag [ mkPlainWarnMsg loc (text warn) | CmdLine.Warn _ (L loc warn) <- warns' ] - printOrThrowWarnings dflags bag + printOrThrowWarnings logger dflags bag -- | Checks if given 'WarnMsg' is a fatal warning. isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) @@ -74,8 +75,8 @@ shouldPrintWarning _ _ -- | Given a bag of warnings, turn them into an exception if -- -Werror is enabled, or print them out otherwise. -printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () -printOrThrowWarnings dflags warns = do +printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings logger dflags warns = do let (make_error, warns') = mapAccumBagL (\make_err warn -> @@ -89,4 +90,4 @@ printOrThrowWarnings dflags warns = do False warns if make_error then throwIO (mkSrcErr warns') - else printBagOfErrors dflags warns + else printBagOfErrors logger dflags warns diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 4f7dcbcaea..bbf7a3336c 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -203,6 +203,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Data.Bag @@ -243,10 +244,12 @@ newHscEnv dflags = do nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv emptyLoader <- uninitializedLoader + logger <- initLogger -- FIXME: it's sad that we have so many "unitialized" fields filled with -- empty stuff or lazy panics. We should have two kinds of HscEnv -- (initialized or not) instead and less fields that are mutable over time. return HscEnv { hsc_dflags = dflags + , hsc_logger = logger , hsc_targets = [] , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags @@ -280,8 +283,9 @@ getHscEnv = Hsc $ \e w -> return (e, w) handleWarnings :: Hsc () handleWarnings = do dflags <- getDynFlags + logger <- getLogger w <- getWarnings - liftIO $ printOrThrowWarnings dflags w + liftIO $ printOrThrowWarnings logger dflags w clearWarnings -- | log warning in the monad, and if there are errors then @@ -301,8 +305,9 @@ handleWarningsThrowErrors (warnings, errors) = do errs = fmap pprError errors logWarnings warns dflags <- getDynFlags + logger <- getLogger (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings - liftIO $ printBagOfErrors dflags wWarns + liftIO $ printBagOfErrors logger dflags wWarns throwErrors (unionBags errs wErrs) -- | Deal with errors and warnings returned by a compilation step @@ -388,10 +393,12 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary hscParse' :: ModSummary -> Hsc HsParsedModule hscParse' mod_summary | Just r <- ms_parsed_mod mod_summary = return r - | otherwise = {-# SCC "Parser" #-} - withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) - (const ()) $ do + | otherwise = do dflags <- getDynFlags + logger <- getLogger + {-# SCC "Parser" #-} withTiming logger dflags + (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) + (const ()) $ do let src_filename = ms_hspp_file mod_summary maybe_src_buf = ms_hspp_buf mod_summary @@ -414,11 +421,11 @@ hscParse' mod_summary POk pst rdr_module -> do let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst) logWarnings warns - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" FormatHaskell (showAstData NoBlankSrcSpan rdr_module) - liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics" FormatText (ppSourceStats False rdr_module) when (not $ isEmptyBag errs) $ throwErrors errs @@ -474,7 +481,8 @@ extract_renamed_stuff mod_summary tc_result = do let rn_info = getRenamedStuff tc_result dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" + logger <- getLogger + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer" FormatHaskell (showAstData NoBlankSrcSpan rn_info) -- Create HIE files @@ -484,7 +492,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 dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) -- Validate HIE files when (gopt Opt_ValidateHie dflags) $ do @@ -492,18 +500,18 @@ extract_renamed_stuff mod_summary tc_result = do liftIO $ do -- Validate Scopes case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of - [] -> putMsg dflags $ text "Got valid scopes" + [] -> putMsg logger dflags $ text "Got valid scopes" xs -> do - putMsg dflags $ text "Got invalid scopes" - mapM_ (putMsg dflags) xs + putMsg logger dflags $ text "Got invalid scopes" + mapM_ (putMsg logger dflags) xs -- Roundtrip testing file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file case diffFile hieFile (hie_file_result file') of [] -> - putMsg dflags $ text "Got no roundtrip errors" + putMsg logger dflags $ text "Got no roundtrip errors" xs -> do - putMsg dflags $ text "Got roundtrip errors" - mapM_ (putMsg (dopt_set dflags Opt_D_ppr_debug)) xs + putMsg logger dflags $ text "Got roundtrip errors" + mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs return rn_info @@ -844,8 +852,9 @@ finish :: ModSummary -> Hsc HscStatus finish summary tc_result mb_old_hash = do hsc_env <- getHscEnv - let dflags = hsc_dflags hsc_env - bcknd = backend dflags + dflags <- getDynFlags + logger <- getLogger + let bcknd = backend dflags hsc_src = ms_hsc_src summary -- Desugar, if appropriate @@ -889,7 +898,7 @@ finish summary tc_result mb_old_hash = do (iface, mb_old_iface_hash, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash - liftIO $ hscMaybeWriteIface dflags True iface mb_old_iface_hash (ms_location summary) + liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary) return $ case bcknd of NoBackend -> HscNotGeneratingCode iface details @@ -943,8 +952,8 @@ suffixes. The interface file name can be overloaded with "-ohi", except when -} -- | Write interface files -hscMaybeWriteIface :: DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () -hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do +hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () +hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do let force_write_interface = gopt Opt_WriteInterface dflags write_interface = case backend dflags of NoBackend -> False @@ -963,7 +972,7 @@ hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do write_iface dflags' iface = {-# SCC "writeIface" #-} - writeIface dflags' (buildIfName (hiSuf dflags')) iface + writeIface logger dflags' (buildIfName (hiSuf dflags')) iface when (write_interface || force_write_interface) $ do @@ -984,7 +993,7 @@ hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do dt <- dynamicTooState dflags - when (dopt Opt_D_dump_if_trace dflags) $ putMsg dflags $ + when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags $ 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) @@ -1028,10 +1037,13 @@ oneShotMsg :: HscEnv -> RecompileRequired -> IO () oneShotMsg hsc_env recomp = case recomp of UpToDate -> - compilationProgressMsg (hsc_dflags hsc_env) $ + compilationProgressMsg logger dflags $ text "compilation IS NOT required" _ -> return () + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env batchMsg :: Messager batchMsg hsc_env mod_index recomp node = case node of @@ -1039,20 +1051,21 @@ batchMsg hsc_env mod_index recomp node = case node of case recomp of MustCompile -> showMsg (text "Instantiating ") empty UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty + | verbosity dflags >= 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 (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty + | verbosity dflags >= 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 dflags $ + compilationProgressMsg logger dflags $ (showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node) <> reason @@ -1510,6 +1523,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes @@ -1523,7 +1537,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do ----------------- Convert to STG ------------------ (stg_binds, (caf_ccs, caf_cc_stacks)) <- {-# SCC "CoreToStg" #-} - myCoreToStg dflags this_mod prepd_binds + myCoreToStg logger dflags this_mod prepd_binds let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags @@ -1539,7 +1553,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 dflags + withTiming logger dflags (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) $ do cmms <- {-# SCC "StgToCmm" #-} @@ -1549,18 +1563,18 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - lookupHook (\x -> cmmToRawCmmHook x) - (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms + lookupHook (\a -> cmmToRawCmmHook a) + (\dflg _ -> cmmToRawCmm logger dflg) dflags dflags (Just this_mod) cmms let dump a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) + dumpIfSet_dyn logger dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) return a rawcmms1 = Stream.mapM dump rawcmms0 (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} - codeOutput dflags (hsc_units hsc_env) this_mod output_filename location + codeOutput logger dflags (hsc_units hsc_env) this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1 return (output_filename, stub_c_exists, foreign_fps, cg_infos) @@ -1571,6 +1585,7 @@ hscInteractive :: HscEnv -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) hscInteractive hsc_env cgguts location = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -1593,7 +1608,7 @@ hscInteractive hsc_env cgguts location = do comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff ----- (_istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags (hsc_units hsc_env) this_mod location foreign_stubs + <- outputForeignStubs logger dflags (hsc_units hsc_env) this_mod location foreign_stubs return (istub_c_exists, comp_bc, spt_entries) ------------------------------ @@ -1601,15 +1616,16 @@ hscInteractive hsc_env cgguts location = do hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env platform = targetPlatform dflags cmm <- ioMsgMaybe $ do - (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) + (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags home_unit filename return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm) liftIO $ do - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) + dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename @@ -1625,11 +1641,11 @@ 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 dflags Opt_D_dump_cmm "Output Cmm" + dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform cmmgroup) rawCmms <- lookupHook (\x -> cmmToRawCmmHook x) - (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) - _ <- codeOutput dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] [] + (\dflgs _ -> cmmToRawCmm logger dflgs) dflags dflags Nothing (Stream.yield cmmgroup) + _ <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] [] rawCmms return () where @@ -1669,16 +1685,17 @@ doCodeGen :: HscEnv -> Module -> [TyCon] doCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env platform = targetPlatform dflags let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds - dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) + dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) let cmm_stream :: Stream IO CmmGroup ModuleLFInfos -- See Note [Forcing of stg_binds] cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} - lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons + lookupHook stgToCmmHook (StgToCmm.codeGen logger) dflags dflags this_mod data_tycons cost_centre_info stg_binds_w_fvs hpc_info -- codegen consumes a stream of CmmGroup, and produces a new @@ -1688,7 +1705,7 @@ doCodeGen hsc_env this_mod data_tycons let dump1 a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg + dumpIfSet_dyn logger dflags Opt_D_dump_cmm_from_stg "Cmm produced by codegen" FormatCMM (pdoc platform a) return a @@ -1705,22 +1722,22 @@ doCodeGen hsc_env this_mod data_tycons dump2 a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) + dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a return (Stream.mapM dump2 pipeline_stream) -myCoreToStg :: DynFlags -> Module -> CoreProgram +myCoreToStg :: Logger -> DynFlags -> Module -> CoreProgram -> IO ( [StgTopBinding] -- output program , CollectedCCs ) -- CAF cost centre info (declared and used) -myCoreToStg dflags this_mod prepd_binds = do +myCoreToStg logger dflags this_mod prepd_binds = do let (stg_binds, cost_centre_info) = {-# SCC "Core2Stg" #-} coreToStg dflags this_mod prepd_binds stg_binds2 <- {-# SCC "Stg2Stg" #-} - stg2stg dflags this_mod stg_binds + stg2stg logger dflags this_mod stg_binds return (stg_binds2, cost_centre_info) @@ -1977,25 +1994,26 @@ hscParseThing = hscParseThingWithLocation "<interactive>" 1 hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int -> Lexer.P thing -> String -> Hsc thing -hscParseThingWithLocation source linenumber parser str - = withTimingD +hscParseThingWithLocation source linenumber parser str = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger dflags (text "Parser [source]") (const ()) $ {-# SCC "Parser" #-} do - dflags <- getDynFlags - let buf = stringToStringBuffer str - loc = mkRealSrcLoc (fsLit source) linenumber 1 + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 - case unP parser (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> - handleWarningsThrowErrors (getMessages pst) - POk pst thing -> do - logWarningsReportErrors (getMessages pst) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" - FormatHaskell (ppr thing) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" - FormatHaskell (showAstData NoBlankSrcSpan thing) - return thing + case unP parser (initParserState (initParserOpts dflags) buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getMessages pst) + POk pst thing -> do + logWarningsReportErrors (getMessages pst) + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr thing) + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan thing) + return thing {- ********************************************************************** @@ -2039,11 +2057,12 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr dumpIfaceStats :: HscEnv -> IO () dumpIfaceStats hsc_env = do eps <- readIORef (hsc_EPS hsc_env) - dumpIfSet dflags (dump_if_trace || dump_rn_stats) + dumpIfSet logger dflags (dump_if_trace || dump_rn_stats) "Interface statistics" (ifaceStats eps) where dflags = hsc_dflags hsc_env + 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 diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 571aada57f..c36e11914e 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -82,6 +82,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error +import GHC.Utils.Logger import GHC.SysTools.FileCleanup import GHC.Types.Basic @@ -207,9 +208,10 @@ depanalPartial excluded_mods allow_dup_roots = do dflags = hsc_dflags hsc_env targets = hsc_targets hsc_env old_graph = hsc_mod_graph hsc_env + logger = hsc_logger hsc_env - withTiming dflags (text "Chasing dependencies") (const ()) $ do - liftIO $ debugTraceMsg dflags 2 (hcat [ + withTiming logger dflags (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg logger dflags 2 (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))]) @@ -430,6 +432,7 @@ load' how_much mHscMessage mod_graph = do let hpt1 = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env -- The "bad" boot modules are the ones for which we have -- B.hs-boot in the module graph, but no B.hs @@ -454,8 +457,8 @@ load' how_much mHscMessage mod_graph = do checkMod m and_then | m `elementOfUniqSet` all_home_mods = and_then | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) + liftIO $ errorMsg logger dflags + (text "no such module:" <+> quotes (ppr m)) return Failed checkHowMuch how_much $ do @@ -491,7 +494,7 @@ load' how_much mHscMessage mod_graph = do -- write the pruned HPT to allow the old HPT to be GC'd. setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt } - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco) -- Unload any modules which are going to be re-linked this time around. @@ -566,8 +569,8 @@ load' how_much mHscMessage mod_graph = do mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg -- clean up between compilations - let cleanup = cleanCurrentModuleTempFiles . hsc_dflags - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + let cleanup hsc_env = cleanCurrentModuleTempFiles (hsc_logger hsc_env) (hsc_dflags hsc_env) + liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) n_jobs <- case parMakeCount dflags of @@ -594,11 +597,11 @@ load' how_much mHscMessage mod_graph = do then -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep completely successful.") -- Clean up after ourselves hsc_env1 <- getSession - liftIO $ cleanCurrentModuleTempFiles dflags + liftIO $ cleanCurrentModuleTempFiles logger dflags -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. @@ -615,11 +618,11 @@ load' how_much mHscMessage mod_graph = do -- link everything together unit_env <- hsc_unit_env <$> getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env do_linking (hsc_HPT hsc_env1) + linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env do_linking (hsc_HPT hsc_env1) if ghcLink dflags == LinkBinary && isJust ofile && not do_linking then do - liftIO $ errorMsg dflags $ text + liftIO $ errorMsg logger dflags $ text ("output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ @@ -633,7 +636,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 dflags 2 (text "Upsweep partially successful.") + do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep partially successful.") let modsDone_names = map (ms_mod . emsModSummary) modsDone @@ -658,7 +661,7 @@ load' how_much mHscMessage mod_graph = do ] liftIO $ changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps - liftIO $ cleanCurrentModuleTempFiles dflags + liftIO $ cleanCurrentModuleTempFiles logger dflags let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) hpt4 @@ -675,7 +678,7 @@ load' how_much mHscMessage mod_graph = do -- Link everything together unit_env <- hsc_unit_env <$> getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env False hpt5 + linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env False hpt5 modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } loadFinish Failed linkresult @@ -1059,6 +1062,7 @@ parUpsweep parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env -- The bits of shared state we'll be using: @@ -1130,6 +1134,12 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do liftIO $ label_self "main --make thread" + + -- Make the logger thread_safe: we only make the "log" action thread-safe in + -- each worker by setting a LogAction hook, so we need to make the logger + -- thread-safe for other actions (DumpAction, TraceAction). + thread_safe_logger <- liftIO $ makeThreadSafe logger + -- For each module in the module graph, spawn a worker thread that will -- compile this module. let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> @@ -1152,6 +1162,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- Replace the default log_action 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 + -- -- Use a local filesToClean var so that we can clean up -- intermediate files in a timely fashion (as soon as @@ -1159,8 +1171,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- worry about accidentally deleting a simultaneous compile's -- important files. lcl_files_to_clean <- newIORef emptyFilesToClean - let lcl_dflags = dflags { log_action = parLogAction log_queue - , filesToClean = lcl_files_to_clean } + let lcl_dflags = dflags { filesToClean = lcl_files_to_clean } -- Unmask asynchronous exceptions and perform the thread-local -- work to compile the module (see parUpsweep_one). @@ -1172,7 +1183,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do pure Succeeded ModuleNode ems -> parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops - lcl_dflags (hsc_home_unit hsc_env) + lcl_logger lcl_dflags (hsc_home_unit hsc_env) mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_idx (length sccs) @@ -1185,7 +1196,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- interrupt, and the user doesn't have to be informed -- about that. when (fromException exc /= Just ThreadKilled) - (errorMsg lcl_dflags (text (show exc))) + (errorMsg lcl_logger lcl_dflags (text (show exc))) return Failed -- Populate the result MVar. @@ -1216,7 +1227,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup 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 dflags log_queue + printLogs logger dflags log_queue result <- readMVar mvar if succeeded result then return (Just mod) else return Nothing @@ -1229,7 +1240,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- of the upsweep. case cycle of Just mss -> do - liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss) + liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr mss) return (Failed,ok_results) Nothing -> do let success_flag = successIf (all isJust results) @@ -1250,8 +1261,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- Print each message from the log_queue using the log_action from the -- session's DynFlags. - printLogs :: DynFlags -> LogQueue -> IO () - printLogs !dflags (LogQueue ref sem) = read_msgs + printLogs :: Logger -> DynFlags -> LogQueue -> IO () + printLogs !logger !dflags (LogQueue ref sem) = read_msgs where read_msgs = do takeMVar sem msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) @@ -1260,7 +1271,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do print_loop [] = read_msgs print_loop (x:xs) = case x of Just (reason,severity,srcSpan,msg) -> do - putLogMsg dflags reason severity srcSpan msg + putLogMsg logger dflags reason severity srcSpan msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () @@ -1273,6 +1284,8 @@ parUpsweep_one -- ^ The map of home modules and their result MVar -> [[BuildModule]] -- ^ The list of all module loops within the compilation graph. + -> Logger + -- ^ The thread-local Logger -> DynFlags -- ^ The thread-local DynFlags -> HomeUnit @@ -1295,7 +1308,7 @@ parUpsweep_one -- ^ The total number of modules -> IO SuccessFlag -- ^ The result of this compile -parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessage cleanup par_sem +parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_dflags home_unit mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_index num_mods = do let this_build_mod = mkBuildModule0 mod @@ -1399,12 +1412,12 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessag hsc_env <- readMVar hsc_env_var old_hpt <- readIORef old_hpt_var - let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) + let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err) -- Limit the number of parallel compiles. let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem) mb_mod_info <- withSem par_sem $ - handleSourceError (\err -> do logger err; return Nothing) $ do + handleSourceError (\err -> do logg err; return Nothing) $ do -- Have the ModSummary and HscEnv point to our local log_action -- and filesToClean var. let lcl_mod = localize_mod mod @@ -1464,13 +1477,12 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessag where localize_mod mod = mod { ms_hspp_opts = (ms_hspp_opts mod) - { log_action = log_action lcl_dflags - , filesToClean = filesToClean lcl_dflags } } + { filesToClean = filesToClean lcl_dflags } } localize_hsc_env hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { log_action = log_action lcl_dflags - , filesToClean = filesToClean lcl_dflags } } + = hsc_env { hsc_logger = lcl_logger + , hsc_dflags = (hsc_dflags hsc_env) + { filesToClean = filesToClean lcl_dflags } } -- ----------------------------------------------------------------------------- -- @@ -1523,7 +1535,8 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do when (not $ null dropped_ms) $ do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ dropped_ms) + logger <- getLogger + liftIO $ fatalErrorMsg logger dflags (keepGoingPruneErr $ dropped_ms) (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' return (Failed, done') @@ -1541,7 +1554,8 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do upsweep' _old_hpt done (CyclicSCC ms : mods) mod_index nmods = do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + logger <- getLogger + liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr ms) if gopt Opt_KeepGoing dflags then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods else return (Failed, done) @@ -1557,7 +1571,7 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger _mod = defaultWarnErrLogger + let logg _mod = defaultWarnErrLogger hsc_env <- getSession @@ -1580,10 +1594,10 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do mb_mod_info <- handleSourceError - (\err -> do logger mod (Just err); return Nothing) $ do + (\err -> do logg mod (Just err); return Nothing) $ do mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods mod mod_index nmods - logger mod Nothing -- log warnings + logg mod Nothing -- log warnings return (Just mod_info) case mb_mod_info of @@ -1682,9 +1696,9 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind -- We're using the dflags for this module now, obtained by -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - dflags = ms_hspp_opts summary + lcl_dflags = ms_hspp_opts summary prevailing_backend = backend (hsc_dflags hsc_env) - local_backend = backend dflags + local_backend = backend lcl_dflags -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that -- we don't do anything dodgy: these should only work to change @@ -1701,7 +1715,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind _ -> prevailing_backend -- store the corrected backend into the summary - summary' = summary{ ms_hspp_opts = dflags { backend = bcknd } } + summary' = summary{ ms_hspp_opts = lcl_dflags { backend = bcknd } } -- The old interface is ok if -- a) we're compiling a source file, and the old HPT @@ -1745,6 +1759,8 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind implies False _ = True implies True x = x + debug_trace n t = liftIO $ debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) n t + in case () of _ @@ -1752,15 +1768,13 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind -- byte code, we can always use an existing object file -- if it is *stable* (see checkStability). | is_stable_obj, Just hmi <- old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable obj mod:" <+> ppr this_mod_name) + debug_trace 5 (text "skipping stable obj mod:" <+> ppr this_mod_name) return hmi -- object is stable, and we have an entry in the -- old HPT: nothing to do | is_stable_obj, isNothing old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling stable on-disk mod:" <+> ppr this_mod_name) linkable <- liftIO $ findObjectLinkable this_mod obj_fn (expectJust "upsweep1" mb_obj_date) compile_it (Just linkable) SourceUnmodifiedAndStable @@ -1771,8 +1785,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind (bcknd /= NoBackend) `implies` not is_fake_linkable -> ASSERT(isJust old_hmi) -- must be in the old_hpt let Just hmi = old_hmi in do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable BCO mod:" <+> ppr this_mod_name) + debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name) return hmi -- BCO is stable: nothing to do @@ -1782,8 +1795,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind not (isObjectLinkable l), (bcknd /= NoBackend) `implies` not is_fake_linkable, linkableTime l >= ms_hs_date summary -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) compile_it (Just l) SourceUnmodified -- we have an old BCO that is up to date with respect -- to the source: do a recompilation check as normal. @@ -1804,26 +1816,22 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind Just hmi | Just l <- hm_linkable hmi, isObjectLinkable l && linkableTime l == obj_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) compile_it (Just l) SourceUnmodified _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date compile_it_discard_iface (Just linkable) SourceUnmodified -- See Note [Recompilation checking in -fno-code mode] - | writeInterfaceOnlyMode dflags, + | writeInterfaceOnlyMode lcl_dflags, Just if_date <- mb_if_date, if_date >= hs_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping tc'd mod:" <+> ppr this_mod_name) + debug_trace 5 (text "skipping tc'd mod:" <+> ppr this_mod_name) compile_it Nothing SourceUnmodified _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling mod:" <+> ppr this_mod_name) compile_it Nothing SourceModified @@ -2009,7 +2017,7 @@ getModLoop ms graph appearsAsBoot -- any duplicates get clobbered in addListToHpt and never get forced. typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv typecheckLoop dflags hsc_env mods = do - debugTraceMsg dflags 2 $ + debugTraceMsg logger dflags 2 $ text "Re-typechecking loop: " <> ppr mods new_hpt <- fixIO $ \new_hpt -> do @@ -2022,6 +2030,7 @@ typecheckLoop dflags hsc_env mods = do return new_hpt return hsc_env{ hsc_HPT = new_hpt } where + logger = hsc_logger hsc_env old_hpt = hsc_HPT hsc_env hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods @@ -2255,8 +2264,8 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots let default_backend = platformDefaultBackend (targetPlatform dflags) home_unit = hsc_home_unit hsc_env map1 <- case backend dflags of - NoBackend -> enableCodeGenForTH home_unit default_backend map0 - Interpreter -> enableCodeGenForUnboxedTuplesOrSums default_backend map0 + NoBackend -> enableCodeGenForTH logger home_unit default_backend map0 + Interpreter -> enableCodeGenForUnboxedTuplesOrSums logger default_backend map0 _ -> return map0 if null errs then pure $ concat $ modNodeMapElems map1 @@ -2267,6 +2276,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env roots = hsc_targets hsc_env old_summary_map :: ModNodeMap ExtendedModSummary @@ -2348,11 +2358,14 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- the specified target, disable optimization and change the .hi -- and .o file locations to be temporary files. -- See Note [-fno-code mode] -enableCodeGenForTH :: HomeUnit -> Backend +enableCodeGenForTH + :: Logger + -> HomeUnit + -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenForTH home_unit = - enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession +enableCodeGenForTH logger home_unit = + enableCodeGenWhen logger condition should_modify TFL_CurrentModule TFL_GhcSession where condition = isTemplateHaskellOrQQNonBoot should_modify (ModSummary { ms_hspp_opts = dflags }) = @@ -2368,11 +2381,13 @@ enableCodeGenForTH home_unit = -- -- This is used in order to load code that uses unboxed tuples -- or sums into GHCi while still allowing some code to be interpreted. -enableCodeGenForUnboxedTuplesOrSums :: Backend +enableCodeGenForUnboxedTuplesOrSums + :: Logger + -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenForUnboxedTuplesOrSums = - enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule +enableCodeGenForUnboxedTuplesOrSums logger = + enableCodeGenWhen logger condition should_modify TFL_GhcSession TFL_CurrentModule where condition ms = unboxed_tuples_or_sums (ms_hspp_opts ms) && @@ -2390,14 +2405,15 @@ enableCodeGenForUnboxedTuplesOrSums = -- modules. The second parameter is a condition to check before -- marking modules for code generation. enableCodeGenWhen - :: (ModSummary -> Bool) + :: Logger + -> (ModSummary -> Bool) -> (ModSummary -> Bool) -> TempFileLifetime -> TempFileLifetime -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap = +enableCodeGenWhen logger condition should_modify staticLife dynLife bcknd nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary @@ -2412,7 +2428,7 @@ enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap = , ms_mod `Set.member` needs_codegen_set = do let new_temp_file suf dynsuf = do - tn <- newTempName dflags staticLife suf + tn <- newTempName logger dflags staticLife suf let dyn_tn = tn -<.> dynsuf addFilesToClean dflags dynLife [dyn_tn] return tn @@ -2862,9 +2878,10 @@ withDeferredDiagnostics f = do warnings <- liftIO $ newIORef [] errors <- liftIO $ newIORef [] fatals <- liftIO $ newIORef [] + logger <- getLogger let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do - let action = putLogMsg dflags reason severity srcSpan msg + let action = putLogMsg logger dflags reason severity srcSpan msg case severity of SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) @@ -2878,12 +2895,9 @@ withDeferredDiagnostics f = do actions <- atomicModifyIORef' ref $ \i -> ([], i) sequence_ $ reverse actions - setLogAction action = modifySession $ \hsc_env -> - hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } } - MC.bracket - (setLogAction deferDiagnostics) - (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) + (pushLogHookM (const deferDiagnostics)) + (\_ -> popLogHookM >> printDeferredDiagnostics) (\_ -> f) noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 817556ee3e..57377212cb 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -42,6 +42,7 @@ import GHC.Unit.Finder import GHC.Utils.Exception import GHC.Utils.Error +import GHC.Utils.Logger import System.Directory import System.FilePath @@ -60,6 +61,8 @@ import qualified Data.Set as Set doMkDependHS :: GhcMonad m => [FilePath] -> m () doMkDependHS srcs = do + logger <- getLogger + -- Initialisation dflags0 <- GHC.getSessionDynFlags @@ -79,7 +82,7 @@ doMkDependHS srcs = do when (null (depSuffixes dflags)) $ liftIO $ throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") - files <- liftIO $ beginMkDependHS dflags + files <- liftIO $ beginMkDependHS logger dflags -- Do the downsweep to find all the modules targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs @@ -92,7 +95,7 @@ doMkDependHS srcs = do let sorted = GHC.topSortModuleGraph False module_graph Nothing -- Print out the dependencies if wanted - liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) + liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted) -- Process them one by one, dumping results into makefile -- and complaining about cycles @@ -101,10 +104,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 dflags module_graph + liftIO $ dumpModCycles logger dflags module_graph -- Tidy up - liftIO $ endMkDependHS dflags files + liftIO $ endMkDependHS logger dflags 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 @@ -128,11 +131,11 @@ data MkDepFiles mkd_tmp_file :: FilePath, -- Name of the temporary file mkd_tmp_hdl :: Handle } -- Handle of the open temporary file -beginMkDependHS :: DynFlags -> IO MkDepFiles -beginMkDependHS dflags = do +beginMkDependHS :: Logger -> DynFlags -> IO MkDepFiles +beginMkDependHS logger dflags = do -- open a new temp file in which to stuff the dependency info -- as we go along. - tmp_file <- newTempName dflags TFL_CurrentModule "dep" + tmp_file <- newTempName logger dflags TFL_CurrentModule "dep" tmp_hdl <- openFile tmp_file WriteMode -- open the makefile @@ -338,9 +341,9 @@ insertSuffixes file_name extras -- ----------------------------------------------------------------- -endMkDependHS :: DynFlags -> MkDepFiles -> IO () +endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO () -endMkDependHS dflags +endMkDependHS logger dflags (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) = do @@ -366,27 +369,27 @@ endMkDependHS dflags -- Create a backup of the original makefile when (isJust makefile_hdl) - (SysTools.copy dflags ("Backing up " ++ makefile) + (SysTools.copy logger dflags ("Backing up " ++ makefile) makefile (makefile++".bak")) -- Copy the new makefile in place - SysTools.copy dflags "Installing new makefile" tmp_file makefile + SysTools.copy logger dflags "Installing new makefile" tmp_file makefile ----------------------------------------------------------------- -- Module cycles ----------------------------------------------------------------- -dumpModCycles :: DynFlags -> ModuleGraph -> IO () -dumpModCycles dflags module_graph +dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO () +dumpModCycles logger dflags module_graph | not (dopt Opt_D_dump_mod_cycles dflags) = return () | null cycles - = putMsg dflags (text "No module cycles") + = putMsg logger dflags (text "No module cycles") | otherwise - = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles) + = putMsg logger dflags (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 51329aead1..2a4c2c04d6 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -19,6 +19,14 @@ module GHC.Driver.Monad ( Session(..), withSession, modifySession, modifySessionM, withTempSession, + -- * Logger + modifyLogger, + pushLogHookM, + popLogHookM, + putLogMsgM, + putMsgM, + withTimingM, + -- ** Warnings logWarnings, printException, WarnErrLogger, defaultWarnErrLogger @@ -33,7 +41,9 @@ import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors ) import GHC.Utils.Monad import GHC.Utils.Exception import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Types.SrcLoc import GHC.Types.SourceError import Control.Monad @@ -57,7 +67,7 @@ import Data.IORef -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' -- before any call to the GHC API functions can occur. -- -class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where +class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where getSession :: m HscEnv setSession :: HscEnv -> m () @@ -92,13 +102,52 @@ withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a withTempSession f m = withSavedSession $ modifySession f >> m +---------------------------------------- +-- Logging +---------------------------------------- + +-- | Modify the logger +modifyLogger :: GhcMonad m => (Logger -> Logger) -> m () +modifyLogger f = modifySession $ \hsc_env -> + hsc_env { hsc_logger = f (hsc_logger hsc_env) } + +-- | Push a log hook on the stack +pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m () +pushLogHookM = modifyLogger . pushLogHook + +-- | Pop a log hook from the stack +popLogHookM :: GhcMonad m => m () +popLogHookM = modifyLogger popLogHook + +-- | Put a log message +putMsgM :: GhcMonad m => SDoc -> m () +putMsgM doc = do + dflags <- getDynFlags + logger <- getLogger + liftIO $ putMsg logger dflags doc + +-- | Put a log message +putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m () +putLogMsgM reason sev loc doc = do + dflags <- getDynFlags + logger <- getLogger + liftIO $ putLogMsg logger dflags reason sev 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 + -- ----------------------------------------------------------------------------- -- | A monad that allows logging of warnings. logWarnings :: GhcMonad m => WarningMessages -> m () logWarnings warns = do dflags <- getSessionDynFlags - liftIO $ printOrThrowWarnings dflags warns + logger <- getLogger + liftIO $ printOrThrowWarnings logger dflags warns -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, @@ -130,6 +179,9 @@ instance MonadFix Ghc where instance HasDynFlags Ghc where getDynFlags = getSessionDynFlags +instance HasLogger Ghc where + getLogger = hsc_logger <$> getSession + instance GhcMonad Ghc where getSession = Ghc $ \(Session r) -> readIORef r setSession s' = Ghc $ \(Session r) -> writeIORef r s' @@ -180,6 +232,9 @@ instance MonadIO m => MonadIO (GhcT m) where instance MonadIO m => HasDynFlags (GhcT m) where getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) +instance MonadIO m => HasLogger (GhcT m) where + getLogger = GhcT $ \(Session r) -> liftM hsc_logger (liftIO $ readIORef r) + instance ExceptionMonad m => GhcMonad (GhcT m) where getSession = GhcT $ \(Session r) -> liftIO $ readIORef r setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' @@ -190,7 +245,8 @@ instance ExceptionMonad m => GhcMonad (GhcT m) where printException :: GhcMonad m => SourceError -> m () printException err = do dflags <- getSessionDynFlags - liftIO $ printBagOfErrors dflags (srcErrorMessages err) + logger <- getLogger + liftIO $ printBagOfErrors logger dflags (srcErrorMessages err) -- | A function called to log warnings and errors. type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 760442bc19..f5cbebee51 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -75,6 +75,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Exception as Exception +import GHC.Utils.Logger import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import qualified GHC.LanguageExtensions as LangExt @@ -194,7 +195,8 @@ compileOne' m_tc_result mHscMessage source_modified0 = do - debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) + let logger = hsc_logger hsc_env0 + debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp) -- Run the pipeline up to codeGen (so everything up to, but not including, STG) (status, plugin_hsc_env) <- hscIncrementalCompile @@ -228,13 +230,13 @@ compileOne' m_tc_result mHscMessage (HscUpdateBoot iface hmi_details, Interpreter) -> return $! HomeModInfo iface hmi_details Nothing (HscUpdateBoot iface hmi_details, _) -> do - touchObjectFile dflags object_filename + touchObjectFile logger dflags object_filename return $! HomeModInfo iface hmi_details Nothing (HscUpdateSig iface hmi_details, Interpreter) -> do let !linkable = LM (ms_hs_date summary) this_mod [] return $! HomeModInfo iface hmi_details (Just linkable) (HscUpdateSig iface hmi_details, _) -> do - output_fn <- getOutputFilename next_phase + output_fn <- getOutputFilename logger next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) @@ -262,7 +264,7 @@ compileOne' m_tc_result mHscMessage -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info. final_iface <- mkFullIface hsc_env' partial_iface Nothing - liftIO $ hscMaybeWriteIface dflags True final_iface mb_old_iface_hash (ms_location summary) + liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash (ms_location summary) (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location @@ -284,7 +286,7 @@ compileOne' m_tc_result mHscMessage (hs_unlinked ++ stub_o) return $! HomeModInfo final_iface hmi_details (Just linkable) (HscRecomp{}, _) -> do - output_fn <- getOutputFilename next_phase + output_fn <- getOutputFilename logger next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) -- We're in --make mode: finish the compilation pipeline. @@ -339,7 +341,6 @@ compileOne' m_tc_result mHscMessage -- imports a _stub.h file that we created here. current_dir = takeDirectory basename old_paths = includePaths dflags2 - !prevailing_dflags = hsc_dflags hsc_env0 loadAsByteCode | Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0) , not obj @@ -355,14 +356,8 @@ compileOne' m_tc_result mHscMessage = (Interpreter, dflags2 { backend = Interpreter }) | otherwise = (backend dflags, dflags2) - dflags = - dflags3 { includePaths = addQuoteInclude old_paths [current_dir] - , log_action = log_action prevailing_dflags } - -- use the prevailing log_action / log_finaliser, - -- not the one cached in the summary. This is so - -- that we can change the log_action without having - -- to re-summarize all the source files. - hsc_env = hsc_env0 {hsc_dflags = dflags} + dflags = dflags3 { includePaths = addQuoteInclude old_paths [current_dir] } + hsc_env = hsc_env0 {hsc_dflags = dflags} -- -fforce-recomp should also work with --make force_recomp = gopt Opt_ForceRecomp dflags @@ -422,7 +417,8 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- so that ranlib on OS X doesn't complain, see -- https://gitlab.haskell.org/ghc/ghc/issues/12673 -- and https://github.com/haskell/cabal/issues/2257 - empty_stub <- newTempName dflags TFL_CurrentModule "c" + let logger = hsc_logger hsc_env + empty_stub <- newTempName logger dflags TFL_CurrentModule "c" let home_unit = hsc_home_unit hsc_env src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) @@ -487,6 +483,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- folders, such that one runpath would be sufficient for multiple/all -- libraries. link :: GhcLink -- ^ interactive or batch + -> Logger -- ^ Logger -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? @@ -500,38 +497,34 @@ link :: GhcLink -- ^ interactive or batch -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink dflags unit_env +link ghcLink logger dflags unit_env = lookupHook linkHook l dflags ghcLink dflags where - l LinkInMemory _ _ _ - = if platformMisc_ghcWithInterpreter $ platformMisc dflags - then -- Not Linking...(demand linker will do the job) - return Succeeded - else panicBadLink LinkInMemory + l k dflags batch_attempt_linking hpt = case k of + NoLink -> return Succeeded + LinkBinary -> link' logger dflags unit_env batch_attempt_linking hpt + LinkStaticLib -> link' logger dflags unit_env batch_attempt_linking hpt + LinkDynLib -> link' logger dflags unit_env batch_attempt_linking hpt + LinkInMemory + | platformMisc_ghcWithInterpreter $ platformMisc dflags + -> -- Not Linking...(demand linker will do the job) + return Succeeded + | otherwise + -> panicBadLink LinkInMemory - l NoLink _ _ _ - = return Succeeded - - l LinkBinary dflags batch_attempt_linking hpt - = link' dflags unit_env batch_attempt_linking hpt - - l LinkStaticLib dflags batch_attempt_linking hpt - = link' dflags unit_env batch_attempt_linking hpt - - l LinkDynLib dflags batch_attempt_linking hpt - = link' dflags unit_env batch_attempt_linking hpt panicBadLink :: GhcLink -> a panicBadLink other = panic ("link: GHC not built to link this way: " ++ show other) -link' :: DynFlags -- ^ dynamic flags +link' :: Logger + -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? -> HomePackageTable -- ^ what to link -> IO SuccessFlag -link' dflags unit_env batch_attempt_linking hpt +link' logger dflags unit_env batch_attempt_linking hpt | batch_attempt_linking = do let @@ -547,11 +540,11 @@ link' dflags unit_env batch_attempt_linking hpt -- the linkables to link linkables = map (expectJust "link".hm_linkable) home_mod_infos - debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + debugTraceMsg logger dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) -- check for the -no-link flag if isNoLink (ghcLink dflags) - then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + then do debugTraceMsg logger dflags 3 (text "link(batch): linking omitted (-c flag given).") return Succeeded else do @@ -560,14 +553,14 @@ link' dflags unit_env batch_attempt_linking hpt platform = targetPlatform dflags exe_file = exeFileName platform staticLink (outputFile dflags) - linking_needed <- linkingNeeded dflags unit_env staticLink linkables pkg_deps + linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps if not (gopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") + then do debugTraceMsg logger dflags 2 (text exe_file <+> text "is up to date, linking not required.") return Succeeded else do - compilationProgressMsg dflags (text "Linking " <> text exe_file <> text " ...") + compilationProgressMsg logger dflags (text "Linking " <> text exe_file <> text " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of @@ -575,21 +568,21 @@ link' dflags unit_env batch_attempt_linking hpt LinkStaticLib -> linkStaticLib LinkDynLib -> linkDynLibCheck other -> panicBadLink other - link dflags unit_env obj_files pkg_deps + link logger dflags unit_env obj_files pkg_deps - debugTraceMsg dflags 3 (text "link: done") + debugTraceMsg logger dflags 3 (text "link: done") -- linkBinary only returns if it succeeds return Succeeded | otherwise - = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + = do debugTraceMsg logger dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ text " Main.main not exported; not linking.") return Succeeded -linkingNeeded :: DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool -linkingNeeded dflags unit_env staticLink linkables pkg_deps = do +linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool +linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). @@ -622,7 +615,7 @@ linkingNeeded dflags unit_env staticLink linkables pkg_deps = do let (lib_errs,lib_times) = partitionEithers e_lib_times if not (null lib_errs) || any (t <) lib_times then return True - else checkLinkInfo dflags unit_env pkg_deps exe_file + else checkLinkInfo logger dflags unit_env pkg_deps exe_file findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) findHSLib platform ws dirs lib = do @@ -682,12 +675,13 @@ doLink hsc_env stop_phase o_files | otherwise = let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env unit_env = hsc_unit_env hsc_env in case ghcLink dflags of NoLink -> return () - LinkBinary -> linkBinary dflags unit_env o_files [] - LinkStaticLib -> linkStaticLib dflags unit_env o_files [] - LinkDynLib -> linkDynLibCheck dflags unit_env o_files [] + LinkBinary -> linkBinary logger dflags unit_env o_files [] + LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] + LinkDynLib -> linkDynLibCheck logger dflags unit_env o_files [] other -> panicBadLink other @@ -723,6 +717,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) -- 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 (input_basename, suffix) = splitExtension input_fn suffix' = drop 1 suffix -- strip off the . @@ -770,7 +765,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) input_fn' <- case (start_phase, mb_input_buf) of (RealPhase real_start_phase, Just input_buf) -> do let suffix = phaseInputExt real_start_phase - fn <- newTempName dflags TFL_CurrentModule suffix + fn <- newTempName logger dflags TFL_CurrentModule suffix hdl <- openBinaryFile fn WriteMode -- Add a LINE pragma so reported source locations will -- mention the real input file, not this temp file. @@ -780,7 +775,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) return fn (_, _) -> return input_fn - debugTraceMsg dflags 4 (text "Running the pipeline") + debugTraceMsg logger dflags 4 (text "Running the pipeline") r <- runPipeline' start_phase hsc_env env input_fn' maybe_loc foreign_os @@ -810,13 +805,13 @@ 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 dflags 4 + debugTraceMsg logger dflags 4 (text "Running the full pipeline again for -dynamic-too") let dflags' = flip gopt_unset Opt_BuildDynamicToo $ setDynamicNow $ dflags hsc_env' <- newHscEnv dflags' - (dbs,unit_state,home_unit) <- initUnits dflags' Nothing + (dbs,unit_state,home_unit) <- initUnits logger dflags' Nothing let unit_env = UnitEnv { ue_platform = targetPlatform dflags' , ue_namever = ghcNameVersion dflags' @@ -857,6 +852,7 @@ pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath pipeLoop phase input_fn = do env <- getPipeEnv dflags <- getDynFlags + logger <- getLogger -- See Note [Partial ordering on phases] let happensBefore' = happensBefore (targetPlatform dflags) stopPhase = stop_phase env @@ -872,13 +868,13 @@ pipeLoop phase input_fn = do return input_fn output -> do pst <- getPipeState - final_fn <- liftIO $ getOutputFilename + final_fn <- liftIO $ getOutputFilename logger stopPhase output (src_basename env) dflags stopPhase (maybe_loc pst) when (final_fn /= input_fn) $ do let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") - liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn + liftIO $ copyWithHeader logger dflags msg line_prag input_fn final_fn return final_fn @@ -891,7 +887,7 @@ pipeLoop phase input_fn = do " but I wanted to stop at phase " ++ show stopPhase) _ - -> do liftIO $ debugTraceMsg dflags 4 + -> do liftIO $ debugTraceMsg logger dflags 4 (text "Running phase" <+> ppr phase) case phase of @@ -955,9 +951,10 @@ runHookedPhase pp input = do phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath phaseOutputFilename next_phase = do PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv - PipeState{maybe_loc, hsc_env} <- getPipeState - let dflags = hsc_dflags hsc_env - liftIO $ getOutputFilename stop_phase output_spec + PipeState{maybe_loc} <- getPipeState + dflags <- getDynFlags + logger <- getLogger + liftIO $ getOutputFilename logger stop_phase output_spec src_basename dflags next_phase maybe_loc -- | Computes the next output filename for something in the compilation @@ -976,17 +973,17 @@ phaseOutputFilename next_phase = do -- compiling; this can be used to override the default output -- of an object file. (TODO: do we actually need this?) getOutputFilename - :: Phase -> PipelineOutput -> String + :: Logger -> Phase -> PipelineOutput -> String -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath -getOutputFilename stop_phase output basename dflags next_phase maybe_location +getOutputFilename logger stop_phase output basename dflags next_phase maybe_location | is_last_phase, Persistent <- output = persistent_fn | is_last_phase, SpecificFile <- output = case outputFile dflags of Just f -> return f Nothing -> panic "SpecificFile: No filename" | keep_this_output = persistent_fn - | Temporary lifetime <- output = newTempName dflags lifetime suffix - | otherwise = newTempName dflags TFL_CurrentModule + | Temporary lifetime <- output = newTempName logger dflags lifetime suffix + | otherwise = newTempName logger dflags TFL_CurrentModule suffix where hcsuf = hcSuf dflags @@ -1123,8 +1120,9 @@ runPhase (RealPhase (Unlit sf)) input_fn = do , GHC.SysTools.FileOption "" output_fn ] - dflags <- hsc_dflags <$> getPipeSession - liftIO $ GHC.SysTools.runUnlit dflags flags + dflags <- getDynFlags + logger <- getLogger + liftIO $ GHC.SysTools.runUnlit logger dflags flags return (RealPhase (Cpp sf), output_fn) @@ -1135,6 +1133,7 @@ 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 @@ -1144,7 +1143,7 @@ runPhase (RealPhase (Cpp sf)) input_fn if not (xopt LangExt.Cpp dflags1) then do -- we have to be careful to emit warnings only once. unless (gopt Opt_Pp dflags1) $ - liftIO $ handleFlagWarnings dflags1 warns + liftIO $ handleFlagWarnings logger dflags1 warns -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. @@ -1152,7 +1151,7 @@ runPhase (RealPhase (Cpp sf)) input_fn else do output_fn <- phaseOutputFilename (HsPp sf) hsc_env <- getPipeSession - liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env) + liftIO $ doCpp logger (hsc_dflags hsc_env) (hsc_unit_env hsc_env) True{-raw-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file @@ -1162,7 +1161,7 @@ runPhase (RealPhase (Cpp sf)) input_fn <- liftIO $ parseDynamicFilePragma dflags0 src_opts liftIO $ checkProcessArgsResult unhandled_flags unless (gopt Opt_Pp dflags2) $ - liftIO $ handleFlagWarnings dflags2 warns + liftIO $ handleFlagWarnings logger dflags2 warns -- the HsPp pass below will emit warnings setDynFlags dflags2 @@ -1174,6 +1173,7 @@ runPhase (RealPhase (Cpp sf)) input_fn runPhase (RealPhase (HsPp sf)) input_fn = do dflags <- getDynFlags + logger <- getLogger if not (gopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. @@ -1182,7 +1182,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do PipeEnv{src_basename, src_suffix} <- getPipeEnv let orig_fn = src_basename <.> src_suffix output_fn <- phaseOutputFilename (Hsc sf) - liftIO $ GHC.SysTools.runPp dflags + liftIO $ GHC.SysTools.runPp logger dflags ( [ GHC.SysTools.Option orig_fn , GHC.SysTools.Option input_fn , GHC.SysTools.FileOption "" output_fn @@ -1195,7 +1195,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do <- liftIO $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ handleFlagWarnings dflags1 warns + liftIO $ handleFlagWarnings logger dflags1 warns return (RealPhase (Hsc sf), output_fn) @@ -1311,6 +1311,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn runPhase (HscOut src_flavour mod_name result) _ = do dflags <- getDynFlags + logger <- getLogger location <- getLocation src_flavour mod_name setModLocation location @@ -1322,7 +1323,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do return (RealPhase StopLn, panic "No output filename from Hsc when no-code") HscUpToDate _ _ -> - do liftIO $ touchObjectFile dflags o_file + do liftIO $ touchObjectFile logger dflags o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't get Nothing) -- but we touch it anyway, to keep 'make' happy (we think). @@ -1330,7 +1331,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do HscUpdateBoot _ _ -> do -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make - liftIO $ touchObjectFile dflags o_file + liftIO $ touchObjectFile logger dflags o_file return (RealPhase StopLn, o_file) HscUpdateSig _ _ -> do -- We need to create a REAL but empty .o file @@ -1363,7 +1364,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do setIface final_iface final_mod_details -- See Note [Writing interface files] - liftIO $ hscMaybeWriteIface dflags False final_iface mb_old_iface_hash mod_location + liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location stub_o <- liftIO (mapM (compileStub hsc_env') mStub) foreign_os <- liftIO $ @@ -1377,8 +1378,9 @@ runPhase (HscOut src_flavour mod_name result) _ = do runPhase (RealPhase CmmCpp) input_fn = do hsc_env <- getPipeSession + logger <- getLogger output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env) + liftIO $ doCpp logger (hsc_dflags hsc_env) (hsc_unit_env hsc_env) False{-not raw-} input_fn output_fn return (RealPhase Cmm, output_fn) @@ -1478,7 +1480,8 @@ runPhase (RealPhase cc_phase) input_fn ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env - liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( + logger <- getLogger + liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger dflags ( [ GHC.SysTools.FileOption "" input_fn , GHC.SysTools.Option "-o" , GHC.SysTools.FileOption "" output_fn @@ -1535,6 +1538,7 @@ 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 @@ -1556,7 +1560,7 @@ runPhase (RealPhase (As with_cpp)) input_fn -- might be a hierarchical module. liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) - ccInfo <- liftIO $ getCompilerInfo dflags + ccInfo <- liftIO $ getCompilerInfo logger dflags let global_includes = [ GHC.SysTools.Option ("-I" ++ p) | p <- includePathsGlobal cmdline_include_paths ] let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) @@ -1565,7 +1569,7 @@ runPhase (RealPhase (As with_cpp)) input_fn = liftIO $ withAtomicRename outputFilename $ \temp_outputFilename -> as_prog - dflags + logger dflags (local_includes ++ global_includes -- See Note [-fPIC for assembler] ++ map GHC.SysTools.Option pic_c_flags @@ -1598,7 +1602,7 @@ runPhase (RealPhase (As with_cpp)) input_fn , GHC.SysTools.FileOption "" temp_outputFilename ]) - liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") + liftIO $ debugTraceMsg logger dflags 4 (text "Running the assembler") runAssembler input_fn output_fn return (RealPhase next_phase, output_fn) @@ -1607,9 +1611,9 @@ runPhase (RealPhase (As with_cpp)) input_fn ----------------------------------------------------------------------------- -- LlvmOpt phase runPhase (RealPhase LlvmOpt) input_fn = do - hsc_env <- getPipeSession - let dflags = hsc_dflags hsc_env - -- we always (unless -optlo specified) run Opt since we rely on it to + dflags <- getDynFlags + logger <- getLogger + let -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of @@ -1630,7 +1634,7 @@ runPhase (RealPhase LlvmOpt) input_fn = do output_fn <- phaseOutputFilename LlvmLlc - liftIO $ GHC.SysTools.runLlvmOpt dflags + liftIO $ GHC.SysTools.runLlvmOpt logger dflags ( optFlag ++ defaultOptions ++ [ GHC.SysTools.FileOption "" input_fn @@ -1684,7 +1688,8 @@ runPhase (RealPhase LlvmLlc) input_fn = do -- -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa -- - dflags <- hsc_dflags <$> getPipeSession + dflags <- getDynFlags + logger <- getLogger let llvmOpts = case optLevel dflags of 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. @@ -1703,7 +1708,7 @@ runPhase (RealPhase LlvmLlc) input_fn = do output_fn <- phaseOutputFilename next_phase - liftIO $ GHC.SysTools.runLlvmLlc dflags + liftIO $ GHC.SysTools.runLlvmLlc logger dflags ( optFlag ++ defaultOptions ++ [ GHC.SysTools.FileOption "" input_fn @@ -1722,8 +1727,9 @@ runPhase (RealPhase LlvmLlc) input_fn = do runPhase (RealPhase LlvmMangle) input_fn = do let next_phase = As False output_fn <- phaseOutputFilename next_phase - dflags <- hsc_dflags <$> getPipeSession - liftIO $ llvmFixupAsm dflags input_fn output_fn + dflags <- getDynFlags + logger <- getLogger + liftIO $ llvmFixupAsm logger dflags input_fn output_fn return (RealPhase next_phase, output_fn) ----------------------------------------------------------------------------- @@ -1736,8 +1742,9 @@ runPhase (RealPhase MergeForeign) input_fn = do if null foreign_os then panic "runPhase(MergeForeign): no foreign objects" else do - dflags <- hsc_dflags <$> getPipeSession - liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn + dflags <- getDynFlags + logger <- getLogger + liftIO $ joinObjectFiles logger dflags (input_fn : foreign_os) output_fn return (RealPhase StopLn, output_fn) -- warning suppression @@ -1812,14 +1819,14 @@ getHCFilePackages filename = return [] -linkDynLibCheck :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkDynLibCheck dflags unit_env o_files dep_units = do +linkDynLibCheck :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLibCheck logger dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ - putLogMsg dflags NoReason SevInfo noSrcSpan + putLogMsg logger dflags NoReason SevInfo 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.") - linkDynLib dflags unit_env o_files dep_units + linkDynLib logger dflags unit_env o_files dep_units -- ----------------------------------------------------------------------------- @@ -1828,8 +1835,8 @@ linkDynLibCheck dflags unit_env o_files dep_units = do -- | Run CPP -- -- UnitState is needed to compute MIN_VERSION macros -doCpp :: DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags unit_env raw input_fn output_fn = do +doCpp :: Logger -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () +doCpp logger dflags unit_env raw input_fn output_fn = do let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags let unit_state = ue_units unit_env @@ -1843,8 +1850,8 @@ doCpp dflags unit_env raw input_fn output_fn = do let verbFlags = getVerbFlags dflags - let cpp_prog args | raw = GHC.SysTools.runCpp dflags args - | otherwise = GHC.SysTools.runCc Nothing dflags (GHC.SysTools.Option "-E" : args) + let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args + | otherwise = GHC.SysTools.runCc Nothing logger dflags (GHC.SysTools.Option "-E" : args) let platform = targetPlatform dflags targetArch = stringEncodeArch $ platformArch platform @@ -1875,7 +1882,7 @@ doCpp dflags unit_env raw input_fn output_fn = do [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - backend_defs <- getBackendDefs dflags + backend_defs <- getBackendDefs logger dflags let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] -- Default CPP defines in Haskell source @@ -1887,7 +1894,7 @@ doCpp dflags unit_env raw input_fn output_fn = do pkgs = catMaybes (map (lookupUnit unit_state) uids) mb_macro_include <- if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + then do macro_stub <- newTempName logger dflags TFL_CurrentModule "h" writeFile macro_stub (generatePackageVersionMacros pkgs) -- Include version macros for every *exposed* package. -- Without -hide-all-packages and with a package database @@ -1927,9 +1934,9 @@ doCpp dflags unit_env raw input_fn output_fn = do , GHC.SysTools.FileOption "" output_fn ]) -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | backend dflags == LLVM = do - llvmVer <- figureLlvmVersion dflags +getBackendDefs :: Logger -> DynFlags -> IO [String] +getBackendDefs logger dflags | backend dflags == LLVM = do + llvmVer <- figureLlvmVersion logger dflags return $ case fmap llvmVersionList llvmVer of Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] @@ -1939,7 +1946,7 @@ getBackendDefs dflags | backend dflags == LLVM = do | minor >= 100 = error "getBackendDefs: Unsupported minor version" | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int -getBackendDefs _ = +getBackendDefs _ _ = return [] -- --------------------------------------------------------------------------- @@ -2017,12 +2024,12 @@ via gcc. -} -joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () -joinObjectFiles dflags o_files output_fn = do +joinObjectFiles :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles logger dflags o_files output_fn = do let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' osInfo = platformOS (targetPlatform dflags) - ld_r args = GHC.SysTools.runMergeObjects dflags ( + ld_r args = GHC.SysTools.runMergeObjects logger dflags ( -- See Note [Produce big objects on Windows] concat [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"] @@ -2042,14 +2049,14 @@ joinObjectFiles dflags o_files output_fn = do if ldIsGnuLd then do - script <- newTempName dflags TFL_CurrentModule "ldscript" + script <- newTempName logger dflags TFL_CurrentModule "ldscript" cwd <- getCurrentDirectory let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" ld_r [GHC.SysTools.FileOption "" script] else if toolSettings_ldSupportsFilelist toolSettings' then do - filelist <- newTempName dflags TFL_CurrentModule "filelist" + filelist <- newTempName logger dflags TFL_CurrentModule "filelist" writeFile filelist $ unlines o_files ld_r [GHC.SysTools.Option "-filelist", GHC.SysTools.FileOption "" filelist] @@ -2088,10 +2095,10 @@ hscPostBackendPhase _ bcknd = NoBackend -> StopLn Interpreter -> StopLn -touchObjectFile :: DynFlags -> FilePath -> IO () -touchObjectFile dflags path = do +touchObjectFile :: Logger -> DynFlags -> FilePath -> IO () +touchObjectFile logger dflags path = do createDirectoryIfMissing True $ takeDirectory path - GHC.SysTools.touch dflags "Touching object file" path + GHC.SysTools.touch logger dflags "Touching object file" path -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index 88f19d8c2c..53d4e98b0d 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -15,6 +15,7 @@ import GHC.Prelude import GHC.Utils.Monad import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.Driver.Session import GHC.Driver.Phases @@ -118,6 +119,9 @@ getPipeSession = P $ \_env state -> return (state, hsc_env state) instance HasDynFlags CompPipeline where getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) +instance HasLogger CompPipeline where + getLogger = P $ \_env state -> return (state, hsc_logger (hsc_env state)) + setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state -> return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index cee4ba692b..7d32e7ad8a 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -24,7 +24,7 @@ module GHC.Driver.Session ( WarningFlag(..), WarnReason(..), Language(..), PlatformConstants(..), - FatalMessager, LogAction, FlushOut(..), FlushErr(..), + FatalMessager, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, warningGroups, warningHierarchies, @@ -60,12 +60,11 @@ module GHC.Driver.Session ( optimisationFlags, setFlagsFromEnvFile, pprDynFlagsDiff, + flagSpecOf, + smallestGroups, targetProfile, - -- ** Log output - putLogMsg, - -- ** Safe Haskell safeHaskellOn, safeHaskellModeEnabled, safeImportsOn, safeLanguageOn, safeInferOn, @@ -150,9 +149,6 @@ module GHC.Driver.Session ( defaultWays, initDynFlags, -- DynFlags -> IO DynFlags defaultFatalMessager, - defaultLogAction, - defaultLogActionHPrintDoc, - defaultLogActionHPutStrDoc, defaultFlushOut, defaultFlushErr, @@ -249,7 +245,6 @@ import GHC.Utils.Misc import GHC.Utils.GlobalVars import GHC.Data.Maybe import GHC.Utils.Monad -import qualified GHC.Utils.Ppr as Pretty import GHC.Types.SrcLoc import GHC.Types.SafeHaskell import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) @@ -260,11 +255,6 @@ import GHC.Settings import GHC.CmmToAsm.CFG.Weight import {-# SOURCE #-} GHC.Core.Opt.CallerCC -import GHC.Types.Error -import {-# SOURCE #-} GHC.Utils.Error - ( DumpAction, TraceAction - , defaultDumpAction, defaultTraceAction ) -import GHC.Utils.Json import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) @@ -599,11 +589,6 @@ data DynFlags = DynFlags { -- The next available suffix to uniquely name a temp file, updated atomically nextTempSuffix :: IORef Int, - -- Names of files which were generated from -ddump-to-file; used to - -- track which ones we need to truncate because it's our first run - -- through - generatedDumps :: IORef (Set FilePath), - -- hsc dynamic flags dumpFlags :: EnumSet DumpFlag, generalFlags :: EnumSet GeneralFlag, @@ -645,10 +630,6 @@ data DynFlags = DynFlags { ghciHistSize :: Int, - -- | SDoc output action: use "GHC.Utils.Error" instead of this if you can - log_action :: LogAction, - dump_action :: DumpAction, - trace_action :: TraceAction, flushOut :: FlushOut, flushErr :: FlushErr, @@ -1084,7 +1065,6 @@ initDynFlags dflags = do refNextTempSuffix <- newIORef 0 refFilesToClean <- newIORef emptyFilesToClean refDirsToClean <- newIORef Map.empty - refGeneratedDumps <- newIORef Set.empty refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing wrapperNum <- newIORef emptyModuleEnv @@ -1108,7 +1088,6 @@ initDynFlags dflags = do nextTempSuffix = refNextTempSuffix, filesToClean = refFilesToClean, dirsToClean = refDirsToClean, - generatedDumps = refGeneratedDumps, nextWrapperNum = wrapperNum, useUnicode = useUnicode', useColor = useColor', @@ -1238,7 +1217,6 @@ defaultDynFlags mySettings llvmConfig = nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", filesToClean = panic "defaultDynFlags: No filesToClean", dirsToClean = panic "defaultDynFlags: No dirsToClean", - generatedDumps = panic "defaultDynFlags: No generatedDumps", ghcVersionFile = Nothing, haddockOptions = Nothing, dumpFlags = EnumSet.empty, @@ -1266,12 +1244,6 @@ defaultDynFlags mySettings llvmConfig = ghciHistSize = 50, -- keep a log of length 50 by default - -- Logging - - log_action = defaultLogAction, - dump_action = defaultDumpAction, - trace_action = defaultTraceAction, - flushOut = defaultFlushOut, flushErr = defaultFlushErr, pprUserLength = 5, @@ -1312,119 +1284,13 @@ defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) then Set.singleton WayDyn else Set.empty --------------------------------------------------------------------------- --- --- Note [JSON Error Messages] --- --- When the user requests the compiler output to be dumped as json --- we used to collect them all in an IORef and then print them at the end. --- This doesn't work very well with GHCi. (See #14078) So instead we now --- use the simpler method of just outputting a JSON document inplace to --- stdout. --- --- Before the compiler calls log_action, it has already turned the `ErrMsg` --- into a formatted message. This means that we lose some possible --- information to provide to the user but refactoring log_action is quite --- invasive as it is called in many places. So, for now I left it alone --- and we can refine its behaviour as users request different output. type FatalMessager = String -> IO () -type LogAction = DynFlags - -> WarnReason - -> Severity - -> SrcSpan - -> SDoc - -> IO () - defaultFatalMessager :: FatalMessager defaultFatalMessager = hPutStrLn stderr --- See Note [JSON Error Messages] --- -jsonLogAction :: LogAction -jsonLogAction dflags reason severity srcSpan msg - = - defaultLogActionHPutStrDoc dflags True stdout - (withPprStyle (PprCode CStyle) (doc $$ text "")) - where - str = renderWithContext (initSDocContext dflags defaultUserStyle) msg - doc = renderJSON $ - JSObject [ ( "span", json srcSpan ) - , ( "doc" , JSString str ) - , ( "severity", json severity ) - , ( "reason" , json reason ) - ] - - -defaultLogAction :: LogAction -defaultLogAction dflags reason severity srcSpan msg - = case severity of - SevOutput -> printOut msg - SevDump -> printOut (msg $$ blankLine) - SevInteractive -> putStrSDoc msg - SevInfo -> printErrs msg - SevFatal -> printErrs msg - SevWarning -> printWarns - SevError -> printWarns - where - printOut = defaultLogActionHPrintDoc dflags False stdout - printErrs = defaultLogActionHPrintDoc dflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout - -- Pretty print the warning flag, if any (#10752) - message = mkLocMessageAnn flagMsg severity srcSpan msg - - printWarns = do - hPutChar stderr '\n' - caretDiagnostic <- - if gopt Opt_DiagnosticsShowCaret dflags - then getCaretDiagnostic severity srcSpan - else pure empty - printErrs $ getPprStyle $ \style -> - withPprStyle (setStyleColoured True style) - (message $+$ caretDiagnostic) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. - - flagMsg = - case reason of - NoReason -> Nothing - Reason wflag -> do - spec <- flagSpecOf wflag - return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) - ErrReason Nothing -> - return "-Werror" - ErrReason (Just wflag) -> do - spec <- flagSpecOf wflag - return $ - "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ - ", -Werror=" ++ flagSpecName spec - - warnFlagGrp flag - | gopt Opt_ShowWarnGroups dflags = - case smallestGroups 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 "") - --- | 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 - -- 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 - newtype FlushOut = FlushOut (IO ()) defaultFlushOut :: FlushOut @@ -1793,9 +1659,6 @@ setOutputFile f d = d { outputFile_ = f} setDynOutputFile f d = d { dynOutputFile_ = f} setOutputHi f d = d { outputHi = f} -setJsonLogAction :: DynFlags -> DynFlags -setJsonLogAction d = d { log_action = jsonLogAction } - parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r @@ -1979,10 +1842,6 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do return (dflags4, leftover, warns' ++ warns) --- | Write an error or warning to the 'LogOutput'. -putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO () -putLogMsg dflags = log_action dflags dflags - -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. -- @@ -2648,7 +2507,7 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) , make_ord_flag defGhcFlag "ddump-json" - (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) + (setDumpFlag Opt_D_dump_json ) , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index ba73a7bb59..1410ef2709 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -66,6 +66,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad +import GHC.Utils.Logger import GHC.Types.Id import GHC.Types.Id.Info @@ -136,8 +137,9 @@ 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 dflags + ; withTiming logger dflags (text "Desugar"<+>brackets (ppr mod)) (const ()) $ do { -- Desugar the program @@ -188,7 +190,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 dflags Opt_D_dump_occur_anal "Occurrence analysis" + ; dumpIfSet_dyn logger dflags 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 @@ -284,22 +286,22 @@ and Rec the rest. -} deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, Maybe CoreExpr) +deSugarExpr hsc_env tc_expr = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env -deSugarExpr hsc_env tc_expr = do { - let dflags = hsc_dflags hsc_env + showPass logger dflags "Desugar" - ; showPass dflags "Desugar" - - -- Do desugaring - ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ + -- Do desugaring + (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ dsLExpr tc_expr - ; case mb_core_expr of - Nothing -> return () - Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" - FormatCore (pprCoreExpr expr) + case mb_core_expr of + Nothing -> return () + Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared" + FormatCore (pprCoreExpr expr) - ; return (msgs, mb_core_expr) } + return (msgs, mb_core_expr) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 6ceae258a3..8d95675efe 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -35,10 +35,10 @@ import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Monad +import GHC.Utils.Logger import GHC.Types.SrcLoc import GHC.Types.Basic @@ -84,8 +84,9 @@ addTicksToBinds addTicksToBinds hsc_env mod mod_loc exports tyCons binds | let dflags = hsc_dflags hsc_env - passes = coveragePasses dflags, not (null passes), - Just orig_file <- ml_hs_file mod_loc = do + passes = coveragePasses dflags + , not (null passes) + , Just orig_file <- ml_hs_file mod_loc = do let orig_file2 = guessSourceFile binds orig_file @@ -121,7 +122,8 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 modBreaks <- mkModBreaks hsc_env mod tickCount entries - dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell + let logger = hsc_logger hsc_env + dumpIfSet_dyn logger dflags Opt_D_dump_ticked "HPC" FormatHaskell (pprLHsBinds binds1) return (binds1, HpcInfo tickCount hashNo, modBreaks) diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs index aaa2b5bc65..79959c4661 100644 --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -25,16 +25,17 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.Unique.Supply import GHC.Types.SrcLoc -import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.HsToCore.Monad tracePm :: String -> SDoc -> DsM () tracePm herald doc = do dflags <- getDynFlags + logger <- getLogger printer <- mkPrintUnqualifiedDs - liftIO $ dumpIfSet_dyn_printer printer dflags + liftIO $ dumpIfSet_dyn_printer printer logger dflags 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/Load.hs b/compiler/GHC/Iface/Load.hs index 01b4f4906f..8a1750909b 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -65,6 +65,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Settings.Constants @@ -430,8 +431,11 @@ loadInterface doc_str mod from -- Redo search for our local hole module loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from | otherwise - = withTimingSilentD (text "loading interface") (pure ()) $ - do { -- Read the state + = do + logger <- getLogger + dflags <- getDynFlags + withTimingSilent logger dflags (text "loading interface") (pure ()) $ do + { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv @@ -917,10 +921,10 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file checkBuildDynamicToo _ = return () -- | Write interface file -writeIface :: DynFlags -> FilePath -> ModIface -> IO () -writeIface dflags hi_file_path new_iface +writeIface :: Logger -> DynFlags -> FilePath -> ModIface -> IO () +writeIface logger dflags hi_file_path new_iface = do createDirectoryIfMissing True (takeDirectory hi_file_path) - let printer = TraceBinIFace (debugTraceMsg dflags 3) + let printer = TraceBinIFace (debugTraceMsg logger dflags 3) profile = targetProfile dflags writeBinIface profile printer hi_file_path new_iface @@ -1052,8 +1056,9 @@ For some background on this choice see trac #15269. showIface :: HscEnv -> FilePath -> IO () showIface hsc_env filename = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env unit_state = hsc_units hsc_env - printer = putLogMsg dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle + printer = putLogMsg logger dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. @@ -1067,7 +1072,7 @@ showIface hsc_env filename = do print_unqual = QueryQualify qualifyImportedNames neverQualifyModules neverQualifyPackages - putLogMsg dflags NoReason SevDump noSrcSpan + putLogMsg logger dflags NoReason SevDump noSrcSpan $ withPprStyle (mkDumpStyle print_unqual) $ pprModIface unit_state iface diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index ddeb811564..836c9dc23d 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -73,10 +73,10 @@ import GHC.Types.SourceFile import GHC.Types.TyThing import GHC.Types.HpcInfo -import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Data.Maybe @@ -147,7 +147,7 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do -- Debug printing let unit_state = hsc_units hsc_env - dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText + dumpIfSet_dyn (hsc_logger hsc_env) (hsc_dflags 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 4c529cde83..d0a06173ec 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -139,7 +139,8 @@ checkOldIface checkOldIface hsc_env mod_summary source_modified maybe_iface = do let dflags = hsc_dflags hsc_env - showPass dflags $ + let logger = hsc_logger hsc_env + showPass logger dflags $ "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary) ++ " (use -ddump-hi-diffs for more details)" diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index dedfd1772b..14afbeeb14 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -50,6 +50,7 @@ import GHC.Tc.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut ) import GHC.Utils.Panic +import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err import GHC.Types.ForeignStubs @@ -161,7 +162,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 dflags + Err.withTiming logger dflags (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $ return (ModDetails { md_types = type_env' @@ -174,6 +175,7 @@ mkBootModDetailsTc hsc_env }) 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 @@ -368,7 +370,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_modBreaks = modBreaks }) - = Err.withTiming dflags + = Err.withTiming logger dflags (text "CoreTidy"<+>brackets (ppr mod)) (const ()) $ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags @@ -442,15 +444,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) $ - Err.dumpIfSet_dyn dflags Opt_D_dump_rules + Logger.dumpIfSet_dyn logger dflags Opt_D_dump_rules (showSDoc dflags (ppr CoreTidy <+> text "rules")) - Err.FormatText + FormatText (pprRulesForUser tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds - ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats" - Err.FormatText + ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_core_stats "Core Stats" + FormatText (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon <+> int (cs_tm cs) @@ -478,6 +480,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env -------------------------- trimId :: Bool -> Id -> Id diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index ded7ab007e..0cc11a1bab 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -73,6 +73,7 @@ import GHC.Unit.Home.ModInfo import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Data.Bag import GHC.Data.Maybe @@ -1202,8 +1203,9 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd exprsFreeIdsList args') ; case lintExpr dflags in_scope rhs' of Nothing -> return () - Just errs -> liftIO $ - displayLintResults dflags False doc + Just errs -> do + logger <- getLogger + liftIO $ displayLintResults logger dflags False doc (pprCoreExpr rhs') (emptyBag, errs) } ; return (bndrs', args', rhs') } @@ -1724,10 +1726,11 @@ tcPragExpr is_compulsory toplvl name expr whenGOptM Opt_DoCoreLinting $ do in_scope <- get_in_scope dflags <- getDynFlags + logger <- getLogger case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of Nothing -> return () Just errs -> liftIO $ - displayLintResults dflags False doc + displayLintResults logger dflags False doc (pprCoreExpr core_expr') (emptyBag, errs) return core_expr' where diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs index 0a186bfcd6..7f4d6cae21 100644 --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -22,12 +22,13 @@ import GHC.Unit.State import GHC.Linker.MacOS import GHC.Linker.Unit import GHC.SysTools.Tasks +import GHC.Utils.Logger import qualified Data.Set as Set import System.FilePath -linkDynLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkDynLib dflags0 unit_env o_files dep_packages +linkDynLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLib logger dflags0 unit_env o_files dep_packages = do let platform = ue_platform unit_env os = platformOS platform @@ -103,7 +104,7 @@ linkDynLib dflags0 unit_env o_files dep_packages Just s -> s Nothing -> "HSdll.dll" - runLink dflags ( + runLink logger dflags ( map Option verbFlags ++ [ Option "-o" , FileOption "" output_fn @@ -163,7 +164,7 @@ linkDynLib dflags0 unit_env o_files dep_packages instName <- case dylibInstallName dflags of Just n -> return n Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) - runLink dflags ( + runLink logger dflags ( map Option verbFlags ++ [ Option "-dynamiclib" , Option "-o" @@ -191,7 +192,7 @@ linkDynLib dflags0 unit_env o_files dep_packages -- See Note [Dynamic linking on macOS] ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] ) - runInjectRPaths dflags pkg_lib_paths output_fn + runInjectRPaths logger dflags pkg_lib_paths output_fn _ -> do ------------------------------------------------------------------- -- Making a DSO @@ -205,7 +206,7 @@ linkDynLib dflags0 unit_env o_files dep_packages -- See Note [-Bsymbolic assumptions by GHC] ["-Wl,-Bsymbolic" | not unregisterised] - runLink dflags ( + runLink logger dflags ( map Option verbFlags ++ libmLinkOpts ++ [ Option "-o" diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs index 455cb3c2a4..8e95f62d84 100644 --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -31,11 +31,11 @@ import GHC.Utils.Asm import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable +import GHC.Utils.Logger import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Types.SrcLoc ( noSrcSpan ) import qualified GHC.Data.ShortText as ST import GHC.SysTools.Elf @@ -48,13 +48,13 @@ import Control.Monad.IO.Class import Control.Monad import Data.Maybe -mkExtraObj :: DynFlags -> UnitState -> Suffix -> String -> IO FilePath -mkExtraObj dflags unit_state extn xs - = do cFile <- newTempName dflags TFL_CurrentModule extn - oFile <- newTempName dflags TFL_GhcSession "o" +mkExtraObj :: Logger -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath +mkExtraObj logger dflags unit_state extn xs + = do cFile <- newTempName logger dflags TFL_CurrentModule extn + oFile <- newTempName logger dflags TFL_GhcSession "o" writeFile cFile xs - ccInfo <- liftIO $ getCompilerInfo dflags - runCc Nothing dflags + ccInfo <- liftIO $ getCompilerInfo logger dflags + runCc Nothing logger dflags ([Option "-c", FileOption "" cFile, Option "-o", @@ -87,15 +87,14 @@ mkExtraObj dflags unit_state extn xs -- -- On Windows, when making a shared library we also may need a DllMain. -- -mkExtraObjToLinkIntoBinary :: DynFlags -> UnitState -> IO FilePath -mkExtraObjToLinkIntoBinary dflags unit_state = do +mkExtraObjToLinkIntoBinary :: Logger -> DynFlags -> UnitState -> IO FilePath +mkExtraObjToLinkIntoBinary logger dflags unit_state = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ - putLogMsg dflags NoReason SevInfo noSrcSpan - $ withPprStyle defaultUserStyle + logInfo logger dflags $ 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.") - mkExtraObj dflags unit_state "c" (showSDoc dflags main) + mkExtraObj logger dflags unit_state "c" (showSDoc dflags main) where main | gopt Opt_NoHsMain dflags = Outputable.empty @@ -153,12 +152,12 @@ mkExtraObjToLinkIntoBinary dflags unit_state = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary dflags unit_env dep_packages = do +mkNoteObjsToLinkIntoBinary :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary logger dflags unit_env dep_packages = do link_info <- getLinkInfo dflags unit_env dep_packages if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj dflags unit_state "s" (showSDoc dflags (link_opts link_info)) + then fmap (:[]) $ mkExtraObj logger dflags unit_state "s" (showSDoc dflags (link_opts link_info)) else return [] where @@ -216,8 +215,8 @@ ghcLinkInfoNoteName = "GHC link info" -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool -checkLinkInfo dflags unit_env pkg_deps exe_file +checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo logger dflags unit_env pkg_deps exe_file | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) -- ToDo: Windows and OS X do not use the ELF binary format, so -- readelf does not work there. We need to find another way to do @@ -228,11 +227,11 @@ checkLinkInfo dflags unit_env pkg_deps exe_file | otherwise = do link_info <- getLinkInfo dflags unit_env pkg_deps - debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString dflags exe_file + debugTraceMsg logger dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString logger dflags exe_file ghcLinkInfoSectionName ghcLinkInfoNoteName let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg dflags 3 $ case m_exe_link_info of + debugTraceMsg logger dflags 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 96688f8d08..4533bc014f 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -70,6 +70,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Unit.Env import GHC.Unit.Finder @@ -308,6 +309,7 @@ loadCmdLineLibs' hsc_env pls = let dflags@(DynFlags { ldInputs = cmdline_ld_inputs , libraryPaths = lib_paths_base}) = hsc_dflags hsc_env + let logger = hsc_logger hsc_env -- (c) Link libraries from the command-line let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] @@ -323,20 +325,20 @@ loadCmdLineLibs' hsc_env pls = OSMinGW32 -> "pthread" : minus_ls_1 _ -> minus_ls_1 -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths dflags os + gcc_paths <- getGCCPaths logger dflags os lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base - maybePutStrLn dflags "Search directories (user):" - maybePutStr dflags (unlines $ map (" "++) lib_paths_env) - maybePutStrLn dflags "Search directories (gcc):" - maybePutStr dflags (unlines $ map (" "++) gcc_paths) + 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) libspecs <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls -- (d) Link .o files from the command-line - classified_ld_inputs <- mapM (classifyLdInput dflags) + classified_ld_inputs <- mapM (classifyLdInput logger dflags) [ f | FileOption _ f <- cmdline_ld_inputs ] -- (e) Link any MacOS frameworks @@ -368,13 +370,13 @@ loadCmdLineLibs' hsc_env pls = pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls merged_specs - maybePutStr dflags "final link ... " + maybePutStr logger dflags "final link ... " ok <- resolveObjs hsc_env -- DLLs are loaded, reset the search paths mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache - if succeeded ok then maybePutStrLn dflags "done" + if succeeded ok then maybePutStrLn logger dflags "done" else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") return pls1 @@ -417,12 +419,12 @@ package I want to link in eagerly". Would that be too complicated for users? -} -classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) -classifyLdInput dflags f +classifyLdInput :: Logger -> DynFlags -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput logger dflags f | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do - putLogMsg dflags NoReason SevInfo noSrcSpan + putLogMsg logger dflags NoReason SevInfo noSrcSpan $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing @@ -432,22 +434,22 @@ preloadLib :: HscEnv -> [String] -> [String] -> LoaderState -> LibrarySpec -> IO LoaderState preloadLib hsc_env lib_paths framework_paths pls lib_spec = do - maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + maybePutStr logger dflags ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of Objects static_ishs -> do (b, pls1) <- preload_statics lib_paths static_ishs - maybePutStrLn dflags (if b then "done" else "not found") + maybePutStrLn logger dflags (if b then "done" else "not found") return pls1 Archive static_ish -> do b <- preload_static_archive lib_paths static_ish - maybePutStrLn dflags (if b then "done" else "not found") + maybePutStrLn logger dflags (if b then "done" else "not found") return pls DLL dll_unadorned -> do maybe_errstr <- loadDLL hsc_env (platformSOName platform dll_unadorned) case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" + Nothing -> maybePutStrLn logger dflags "done" Just mm | platformOS platform /= OSDarwin -> preloadFailed mm lib_paths lib_spec Just mm | otherwise -> do @@ -457,14 +459,14 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do let libfile = ("lib" ++ dll_unadorned) <.> "so" err2 <- loadDLL hsc_env libfile case err2 of - Nothing -> maybePutStrLn dflags "done" + Nothing -> maybePutStrLn logger dflags "done" Just _ -> preloadFailed mm lib_paths lib_spec return pls DLLPath dll_path -> do do maybe_errstr <- loadDLL hsc_env dll_path case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" + Nothing -> maybePutStrLn logger dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec return pls @@ -472,19 +474,20 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do if platformUsesFrameworks (targetPlatform dflags) then do maybe_errstr <- loadFramework hsc_env framework_paths framework case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" + Nothing -> maybePutStrLn logger dflags "done" Just mm -> preloadFailed mm framework_paths lib_spec return pls else throwGhcExceptionIO (ProgramError "preloadLib Framework") where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env platform = targetPlatform dflags preloadFailed :: String -> [String] -> LibrarySpec -> IO () preloadFailed sys_errmsg paths spec - = do maybePutStr dflags "failed.\n" + = do maybePutStr logger dflags "failed.\n" throwGhcExceptionIO $ CmdLineError ( "user specified .o/.so/.DLL could not be loaded (" @@ -914,12 +917,13 @@ dynLoadObjs :: HscEnv -> LoaderState -> [FilePath] -> IO LoaderState dynLoadObjs _ pls [] = return pls dynLoadObjs hsc_env pls@LoaderState{..} objs = do let unit_env = hsc_unit_env hsc_env - let dflags = hsc_dflags hsc_env + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env let platform = ue_platform unit_env let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] (soFile, libPath , libName) <- - newTempLibName dflags TFL_CurrentModule (platformSOExt platform) + newTempLibName logger dflags TFL_CurrentModule (platformSOExt platform) let dflags2 = dflags { -- We don't want the original ldInputs in @@ -965,7 +969,7 @@ dynLoadObjs hsc_env pls@LoaderState{..} objs = do -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again. - linkDynLib dflags2 unit_env objs pkgs_loaded + linkDynLib logger dflags2 unit_env objs pkgs_loaded -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime dflags TFL_GhcSession [soFile] @@ -1096,9 +1100,10 @@ unload hsc_env linkables return (pls1, pls1) let dflags = hsc_dflags hsc_env - debugTraceMsg dflags 3 $ + let logger = hsc_logger hsc_env + debugTraceMsg logger dflags 3 $ text "unload: retaining objs" <+> ppr (objs_loaded new_pls) - debugTraceMsg dflags 3 $ + debugTraceMsg logger dflags 3 $ text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) return () @@ -1276,6 +1281,7 @@ loadPackage :: HscEnv -> UnitInfo -> IO () loadPackage hsc_env pkg = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env platform = targetPlatform dflags is_dyn = interpreterDynamic (hscInterp hsc_env) dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg @@ -1303,7 +1309,7 @@ loadPackage hsc_env pkg extra_libs = extdeplibs ++ linkerlibs -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths dflags (platformOS platform) + gcc_paths <- getGCCPaths logger dflags (platformOS platform) dirs_env <- addEnvPaths "LIBRARY_PATH" dirs hs_classifieds @@ -1325,7 +1331,7 @@ loadPackage hsc_env pkg all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env - maybePutSDoc dflags + maybePutSDoc logger dflags (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") -- See comments with partOfGHCi @@ -1345,7 +1351,7 @@ loadPackage hsc_env pkg mapM_ (loadObj hsc_env) objs mapM_ (loadArchive hsc_env) archs - maybePutStr dflags "linking ... " + maybePutStr logger dflags "linking ... " ok <- resolveObjs hsc_env -- DLLs are loaded, reset the search paths @@ -1355,7 +1361,7 @@ loadPackage hsc_env pkg mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache if succeeded ok - then maybePutStrLn dflags "done." + then maybePutStrLn logger dflags "done." else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) @@ -1415,12 +1421,14 @@ load_dyn hsc_env crash_early dll = do Just err -> if crash_early then cmdLineErrorIO err - else let dflags = hsc_dflags hsc_env in + else when (wopt Opt_WarnMissedExtraSharedLib dflags) - $ putLogMsg dflags + $ putLogMsg logger dflags (Reason Opt_WarnMissedExtraSharedLib) SevWarning noSrcSpan $ withPprStyle defaultUserStyle (note err) where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env note err = vcat $ map text [ err , "It's OK if you don't want to use symbols from it directly." @@ -1500,6 +1508,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env interp = hscInterp hsc_env dirs = lib_dirs ++ gcc_dirs gcc = False @@ -1540,7 +1549,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary hsc_env so_name - tryGcc = let search = searchForLibUsingGcc dflags + tryGcc = let search = searchForLibUsingGcc logger dflags dllpath = liftM (fmap DLLPath) short = dllpath $ search so_name lib_dirs full = dllpath $ search lib_so_name lib_dirs @@ -1570,7 +1579,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib , not loading_dynamic_hs_libs , interpreterProfiled interp = do - warningMsg dflags + warningMsg logger dflags (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.") @@ -1590,11 +1599,11 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib arch = platformArch platform os = platformOS platform -searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) -searchForLibUsingGcc dflags so dirs = do +searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc logger dflags so dirs = do -- GCC does not seem to extend the library search path (using -L) when using -- --print-file-name. So instead pass it a new base location. - str <- askLd dflags (map (FileOption "-B") dirs + str <- askLd logger dflags (map (FileOption "-B") dirs ++ [Option "--print-file-name", Option so]) let file = case lines str of [] -> "" @@ -1606,11 +1615,11 @@ searchForLibUsingGcc dflags so dirs = do -- | Retrieve the list of search directory GCC and the System use to find -- libraries and components. See Note [Fork/Exec Windows]. -getGCCPaths :: DynFlags -> OS -> IO [FilePath] -getGCCPaths dflags os +getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath] +getGCCPaths logger dflags os = case os of OSMinGW32 -> - do gcc_dirs <- getGccSearchDirectory dflags "libraries" + do gcc_dirs <- getGccSearchDirectory logger dflags "libraries" sys_dirs <- getSystemDirectories return $ nub $ gcc_dirs ++ sys_dirs _ -> return [] @@ -1630,13 +1639,13 @@ gccSearchDirCache = unsafePerformIO $ newIORef [] -- which hopefully is written in an optimized mannor to take advantage of -- caching. At the very least we remove the overhead of the fork/exec and waits -- which dominate a large percentage of startup time on Windows. -getGccSearchDirectory :: DynFlags -> String -> IO [FilePath] -getGccSearchDirectory dflags key = do +getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath] +getGccSearchDirectory logger dflags key = do cache <- readIORef gccSearchDirCache case lookup key cache of Just x -> return x Nothing -> do - str <- askLd dflags [Option "--print-search-dirs"] + str <- askLd logger dflags [Option "--print-search-dirs"] let line = dropWhile isSpace str name = key ++ ": =" if null line @@ -1704,17 +1713,17 @@ addEnvPaths name list ********************************************************************* -} -maybePutSDoc :: DynFlags -> SDoc -> IO () -maybePutSDoc dflags s +maybePutSDoc :: Logger -> DynFlags -> SDoc -> IO () +maybePutSDoc logger dflags s = when (verbosity dflags > 1) $ - putLogMsg dflags + putLogMsg logger dflags NoReason SevInteractive noSrcSpan $ withPprStyle defaultUserStyle s -maybePutStr :: DynFlags -> String -> IO () -maybePutStr dflags s = maybePutSDoc dflags (text s) +maybePutStr :: Logger -> DynFlags -> String -> IO () +maybePutStr logger dflags s = maybePutSDoc logger dflags (text s) -maybePutStrLn :: DynFlags -> String -> IO () -maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") +maybePutStrLn :: Logger -> DynFlags -> String -> IO () +maybePutStrLn logger dflags s = maybePutSDoc logger dflags (text s <> text "\n") diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs index be5cbf2f9c..d95255acda 100644 --- a/compiler/GHC/Linker/MacOS.hs +++ b/compiler/GHC/Linker/MacOS.hs @@ -21,6 +21,7 @@ import GHC.SysTools.Tasks import GHC.Runtime.Interpreter (loadDLL) import GHC.Utils.Exception +import GHC.Utils.Logger import Data.List (isPrefixOf, nub, sort, intersperse, intercalate) import Control.Monad (join, forM, filterM) @@ -43,13 +44,13 @@ import System.FilePath ((</>), (<.>)) -- dynamic library through @-add_rpath@. -- -- See Note [Dynamic linking on macOS] -runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO () -runInjectRPaths dflags lib_paths dylib = do - info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib] +runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO () +runInjectRPaths logger dflags lib_paths dylib = do + info <- lines <$> askOtool logger dflags Nothing [Option "-L", Option dylib] -- filter the output for only the libraries. And then drop the @rpath prefix. let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info -- find any pre-existing LC_PATH items - info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib] + info <- fmap words.lines <$> askOtool logger dflags Nothing [Option "-l", Option dylib] let paths = concatMap f info where f ("path":p:_) = [p] f _ = [] @@ -59,7 +60,7 @@ runInjectRPaths dflags lib_paths dylib = do -- inject the rpaths case rpaths of [] -> return () - _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] + _ -> runInstallNameTool logger dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String] getUnitFrameworkOpts unit_env dep_packages diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index 4fa69c00e4..84fbe41e7e 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -20,6 +20,7 @@ import GHC.Unit.Types import GHC.Unit.Info import GHC.Unit.State +import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Utils.Misc @@ -62,11 +63,11 @@ it is supported by both gcc and clang. Anecdotally nvcc supports -Xlinker, but not -Wl. -} -linkBinary :: DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary' staticLink dflags unit_env o_files dep_units = do +linkBinary' :: Bool -> Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary' staticLink logger dflags unit_env o_files dep_units = do let platform = ue_platform unit_env unit_state = ue_units unit_env toolSettings' = toolSettings dflags @@ -121,7 +122,7 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do if gopt Opt_SingleLibFolder dflags then do libs <- getLibs dflags unit_env dep_units - tmpDir <- newTempDir dflags + tmpDir <- newTempDir logger dflags sequence_ [ copyFile lib (tmpDir </> basename) | (lib, basename) <- libs] return [ "-L" ++ tmpDir ] @@ -136,8 +137,8 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags unit_state - noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags unit_env dep_units + extraLinkObj <- mkExtraObjToLinkIntoBinary logger dflags unit_state + noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger dflags unit_env dep_units let (pre_hs_libs, post_hs_libs) @@ -179,16 +180,16 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do let extra_ld_inputs = ldInputs dflags rc_objs <- case platformOS platform of - OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest dflags output_fn + OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger dflags output_fn _ -> return [] - let link dflags args | staticLink = GHC.SysTools.runLibtool dflags args + let link dflags args | staticLink = GHC.SysTools.runLibtool logger dflags args | platformOS platform == OSDarwin = do - GHC.SysTools.runLink dflags args - GHC.Linker.MacOS.runInjectRPaths dflags pkg_lib_paths output_fn + GHC.SysTools.runLink logger dflags args + GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn | otherwise - = GHC.SysTools.runLink dflags args + = GHC.SysTools.runLink logger dflags args link dflags ( map GHC.SysTools.Option verbFlags @@ -269,8 +270,8 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do -- | Linking a static lib will not really link anything. It will merely produce -- a static archive of all dependent static libraries. The resulting library -- will still need to be linked with any remaining link flags. -linkStaticLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkStaticLib dflags unit_env o_files dep_units = do +linkStaticLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkStaticLib logger dflags unit_env o_files dep_units = do let platform = ue_platform unit_env extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs @@ -302,7 +303,7 @@ linkStaticLib dflags unit_env o_files dep_units = do else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar -- run ranlib over the archive. write*Ar does *not* create the symbol index. - runRanlib dflags [GHC.SysTools.FileOption "" output_fn] + runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn] diff --git a/compiler/GHC/Linker/Windows.hs b/compiler/GHC/Linker/Windows.hs index 3bbe83f10e..8e1f60d2c6 100644 --- a/compiler/GHC/Linker/Windows.hs +++ b/compiler/GHC/Linker/Windows.hs @@ -7,15 +7,17 @@ import GHC.Prelude import GHC.SysTools import GHC.Driver.Session import GHC.SysTools.FileCleanup +import GHC.Utils.Logger import System.FilePath import System.Directory maybeCreateManifest - :: DynFlags + :: Logger + -> DynFlags -> FilePath -- ^ filename of executable -> IO [FilePath] -- ^ extra objects to embed, maybe -maybeCreateManifest dflags exe_filename = do +maybeCreateManifest logger dflags exe_filename = do let manifest_filename = exe_filename <.> "manifest" manifest = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ @@ -42,9 +44,9 @@ maybeCreateManifest dflags exe_filename = do if not (gopt Opt_EmbedManifest dflags) then return [] else do - rc_filename <- newTempName dflags TFL_CurrentModule "rc" + rc_filename <- newTempName logger dflags TFL_CurrentModule "rc" rc_obj_filename <- - newTempName dflags TFL_GhcSession (objectSuf dflags) + newTempName logger dflags TFL_GhcSession (objectSuf dflags) writeFile rc_filename $ "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" @@ -52,7 +54,7 @@ maybeCreateManifest dflags exe_filename = do -- show is a bit hackish above, but we need to escape the -- backslashes in the path. - runWindres dflags $ map GHC.SysTools.Option $ + runWindres logger dflags $ map GHC.SysTools.Option $ ["--input="++rc_filename, "--output="++rc_obj_filename, "--output-format=coff"] diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 19d9d333ec..b0e6bb1159 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.Error ( dumpIfSet_dyn_printer, DumpFormat (..) ) +import GHC.Utils.Logger ( dumpIfSet_dyn_printer, DumpFormat (..), getLogger ) import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName @@ -808,15 +808,16 @@ data SpliceInfo traceSplice :: SpliceInfo -> TcM () traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , spliceGenerated = gen, spliceIsDecl = is_decl }) - = do { loc <- case mb_src of - Nothing -> getSrcSpanM - Just (L loc _) -> return loc - ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) - - ; when is_decl $ -- Raw material for -dth-dec-file - do { dflags <- getDynFlags - ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file - "" FormatHaskell (spliceCodeDoc loc) } } + = do loc <- case mb_src of + Nothing -> getSrcSpanM + Just (L loc _) -> return loc + 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) where -- `-ddump-splices` spliceDebugDoc :: SrcSpan -> SDoc diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index f49bd358c1..5051a97f52 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -35,6 +35,7 @@ import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Monad import GHC.Utils.Exception +import GHC.Utils.Logger import GHC.Types.Id import GHC.Types.Name @@ -72,7 +73,8 @@ pprintClosureCommand bindThings force str = do unqual <- GHC.getPrintUnqual docterms <- mapM showTerm terms dflags <- getDynFlags - liftIO $ (printOutputForUser dflags unqual . vcat) + logger <- getLogger + liftIO $ (printOutputForUser logger dflags unqual . vcat) (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) ids docterms) @@ -95,8 +97,9 @@ pprintClosureCommand bindThings force str = do case (improveRTTIType hsc_env id_ty' reconstructed_type) of Nothing -> return (subst, term') Just subst' -> do { dflags <- GHC.getSessionDynFlags + ; logger <- getLogger ; liftIO $ - dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI" FormatText (fsep $ [text "RTTI Improvement for", ppr id, text "old substitution:" , ppr subst, @@ -175,20 +178,26 @@ showTerm term = do if not (isFullyEvaluatedTerm t) then return Nothing else do - hsc_env <- getSession - dflags <- GHC.getSessionDynFlags - do - (new_env, bname) <- bindToFreshName hsc_env ty "showme" - setSession new_env - -- XXX: this tries to disable logging of errors - -- does this still do what it is intended to do - -- with the changed error handling and logging? - let noop_log _ _ _ _ _ = return () - expr = "Prelude.return (Prelude.show " ++ + let set_session = do + hsc_env <- getSession + (new_env, bname) <- bindToFreshName hsc_env ty "showme" + setSession new_env + + -- this disables logging of errors + let noop_log _ _ _ _ _ = return () + pushLogHookM (const noop_log) + + return (hsc_env, bname) + + reset_session (old_env,_) = setSession old_env + + MC.bracket set_session reset_session $ \(_,bname) -> do + hsc_env <- getSession + dflags <- GHC.getSessionDynFlags + let expr = "Prelude.return (Prelude.show " ++ showPpr dflags bname ++ ") :: Prelude.IO Prelude.String" dl = hsc_loader hsc_env - GHC.setSessionDynFlags dflags{log_action=noop_log} txt_ <- withExtendedLoadedEnv dl [(bname, fhv)] (GHC.compileExprRemote expr) @@ -198,9 +207,7 @@ showTerm term = do return $ Just $ cparen (prec >= myprec && needsParens txt) (text txt) else return Nothing - `MC.finally` do - setSession hsc_env - GHC.setSessionDynFlags dflags + cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = cPprShowable prec t{ty=new_ty} cPprShowable _ _ = return Nothing diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index d1cc9e56c1..c2626ce6b3 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -93,6 +93,7 @@ import GHC.Utils.Panic import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.RepType import GHC.Types.Fixity.Env @@ -552,7 +553,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do mb_hValues <- mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets when (any isNothing mb_hValues) $ - debugTraceMsg (hsc_dflags hsc_env) 1 $ + debugTraceMsg (hsc_logger hsc_env) (hsc_dflags 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 @@ -644,7 +645,8 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do ++ "improvement for a type")) hsc_env Just subst -> do let dflags = hsc_dflags hsc_env - dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + let logger = hsc_logger hsc_env + dumpIfSet_dyn logger dflags 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 244f18e355..683860ff20 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -55,6 +55,7 @@ import GHC.Unit.Module ( Module, ModuleName ) import GHC.Unit.Module.ModIface import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception @@ -191,10 +192,11 @@ getValueSafely hsc_env val_name expected_type = do case mb_hval of Nothing -> return Nothing Just hval -> do - value <- lessUnsafeCoerce dflags "getValueSafely" hval + value <- lessUnsafeCoerce logger dflags "getValueSafely" hval return (Just value) where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) getHValueSafely hsc_env val_name expected_type = do @@ -226,12 +228,12 @@ getHValueSafely hsc_env 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 :: DynFlags -> String -> a -> IO b -lessUnsafeCoerce dflags context what = do - debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> - (text "...") +lessUnsafeCoerce :: Logger -> DynFlags -> String -> a -> IO b +lessUnsafeCoerce logger dflags context what = do + debugTraceMsg logger dflags 3 $ + (text "Coercing a value in") <+> (text context) <> (text "...") output <- evaluate (unsafeCoerce what) - debugTraceMsg dflags 3 (text "Successfully evaluated coercion") + debugTraceMsg logger dflags 3 (text "Successfully evaluated coercion") return output diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 32b213be45..0ee7381fe0 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -54,6 +54,7 @@ import GHC.Utils.Error ( Severity(..), mkLocMessage ) import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc +import GHC.Utils.Logger import GHC.Utils.Outputable import GHC.Unit.Module ( Module ) import qualified GHC.Utils.Error as Err @@ -61,20 +62,21 @@ import Control.Applicative ((<|>)) import Control.Monad lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) - => DynFlags + => Logger + -> DynFlags -> Module -- ^ module being compiled -> Bool -- ^ have we run Unarise yet? -> String -- ^ who produced the STG? -> [GenStgTopBinding a] -> IO () -lintStgTopBindings dflags this_mod unarised whodunnit binds +lintStgTopBindings logger dflags this_mod unarised whodunnit binds = {-# SCC "StgLint" #-} case initL this_mod unarised opts top_level_binds (lint_binds binds) of Nothing -> return () Just msg -> do - putLogMsg dflags NoReason Err.SevDump noSrcSpan + putLogMsg logger dflags NoReason Err.SevDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunnit <+> text "***", @@ -82,7 +84,7 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds text "*** Offending Program ***", pprGenStgTopBindings opts binds, text "*** End of Offense ***"]) - Err.ghcExit dflags 1 + Err.ghcExit logger dflags 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 ea758e58db..c05450c0f7 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -30,6 +30,7 @@ import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict @@ -46,14 +47,15 @@ instance MonadUnique StgM where runStgM :: Char -> StgM a -> IO a runStgM mask (StgM m) = evalStateT m mask -stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do +stg2stg :: Logger + -> DynFlags -- includes spec of what stg-to-stg passes to do -> Module -- module being compiled -> [StgTopBinding] -- input program -> IO [StgTopBinding] -- output program -stg2stg dflags this_mod binds +stg2stg logger dflags this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds - ; showPass dflags "Stg2Stg" + ; showPass logger dflags "Stg2Stg" -- Do the main business! ; binds' <- runStgM 'g' $ foldM do_stg_pass binds (getStgToDo dflags) @@ -73,7 +75,7 @@ stg2stg dflags this_mod binds where stg_linter unarised | gopt Opt_DoStgLinting dflags - = lintStgTopBindings dflags this_mod unarised + = lintStgTopBindings logger dflags this_mod unarised | otherwise = \ _whodunnit _binds -> return () @@ -106,11 +108,11 @@ stg2stg dflags this_mod binds opts = initStgPprOpts dflags dump_when flag header binds - = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings opts binds) + = dumpIfSet_dyn logger dflags flag header FormatSTG (pprStgTopBindings opts binds) end_pass what binds2 = liftIO $ do -- report verbosely, if required - dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what + dumpIfSet_dyn logger dflags Opt_D_verbose_stg2stg what FormatSTG (vcat (map (pprStgTopBinding opts) binds2)) stg_linter False what binds2 return binds2 diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 2bbf6deac7..3d1f962267 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -57,6 +57,7 @@ import GHC.Unit.Module import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.SysTools.FileCleanup @@ -69,7 +70,8 @@ import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS -codeGen :: DynFlags +codeGen :: Logger + -> DynFlags -> Module -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. @@ -79,7 +81,7 @@ codeGen :: DynFlags -- Output as a stream, so codegen can -- be interleaved with output -codeGen dflags this_mod data_tycons +codeGen logger dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise @@ -87,7 +89,7 @@ codeGen dflags this_mod data_tycons ; cgref <- liftIO $ newIORef =<< initC ; let cg :: FCode () -> Stream IO CmmGroup () cg fcode = do - cmm <- liftIO . withTimingSilent dflags (text "STG -> Cmm") (`seq` ()) $ do + cmm <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do st <- readIORef cgref let (a,st') = runC dflags this_mod st (getCmm fcode) @@ -104,7 +106,7 @@ codeGen dflags this_mod data_tycons -- Note [pipeline-split-init]. ; cg (mkModuleInit cost_centre_info this_mod hpc_info) - ; mapM_ (cg . cgTopBinding dflags) stg_binds + ; mapM_ (cg . cgTopBinding logger dflags) stg_binds -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to @@ -151,14 +153,14 @@ This is so that we can write the top level processing in a compositional style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode () -cgTopBinding dflags (StgTopLifted (StgNonRec id rhs)) +cgTopBinding :: Logger -> DynFlags -> CgStgTopBinding -> FCode () +cgTopBinding _logger dflags (StgTopLifted (StgNonRec id rhs)) = do { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs ; fcode ; addBindC info } -cgTopBinding dflags (StgTopLifted (StgRec pairs)) +cgTopBinding _logger dflags (StgTopLifted (StgRec pairs)) = do { let (bndrs, rhss) = unzip pairs ; let pairs' = zip bndrs rhss r = unzipWith (cgTopRhs dflags Recursive) pairs' @@ -167,7 +169,7 @@ cgTopBinding dflags (StgTopLifted (StgRec pairs)) ; sequence_ fcodes } -cgTopBinding dflags (StgTopStringLit id str) = do +cgTopBinding logger dflags (StgTopStringLit id str) = do let label = mkBytesLabel (idName id) -- emit either a CmmString literal or dump the string in a file and emit a -- CmmFileEmbed literal. @@ -179,7 +181,7 @@ cgTopBinding dflags (StgTopStringLit id str) = do (lit,decl) = if not isNCG || asString then mkByteStringCLit label str else mkFileEmbedLit label $ unsafePerformIO $ do - bFile <- newTempName dflags TFL_CurrentModule ".dat" + bFile <- newTempName logger dflags TFL_CurrentModule ".dat" BS.writeFile bFile str return bFile emitDecl decl diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs index 9e707c3bc4..91b72513f3 100644 --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -36,6 +36,7 @@ import GHC.Settings.Utils import GHC.Utils.Error import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Driver.Session import Control.Monad.Trans.Except (runExceptT) @@ -185,13 +186,13 @@ for more information. -} -copy :: DynFlags -> String -> FilePath -> FilePath -> IO () -copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to +copy :: Logger -> DynFlags -> String -> FilePath -> FilePath -> IO () +copy logger dflags purpose from to = copyWithHeader logger dflags purpose Nothing from to -copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath +copyWithHeader :: Logger -> DynFlags -> String -> Maybe String -> FilePath -> FilePath -> IO () -copyWithHeader dflags purpose maybe_header from to = do - showPass dflags purpose +copyWithHeader logger dflags purpose maybe_header from to = do + showPass logger dflags purpose hout <- openBinaryFile to WriteMode hin <- openBinaryFile from ReadMode diff --git a/compiler/GHC/SysTools/Elf.hs b/compiler/GHC/SysTools/Elf.hs index 197c30624f..7dbfea9d2b 100644 --- a/compiler/GHC/SysTools/Elf.hs +++ b/compiler/GHC/SysTools/Elf.hs @@ -24,6 +24,7 @@ import GHC.Utils.Error import GHC.Data.Maybe (MaybeT(..),runMaybeT) import GHC.Utils.Misc (charToC) import GHC.Utils.Outputable (text,hcat) +import GHC.Utils.Logger import Control.Monad (when) import Data.Binary.Get @@ -141,9 +142,9 @@ data ElfHeader = ElfHeader -- | Read the ELF header -readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader) -readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfHeader :: Logger -> DynFlags -> ByteString -> IO (Maybe ElfHeader) +readElfHeader logger dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF header") return Nothing where @@ -194,13 +195,14 @@ data SectionTable = SectionTable } -- | Read the ELF section table -readElfSectionTable :: DynFlags +readElfSectionTable :: Logger + -> DynFlags -> ElfHeader -> ByteString -> IO (Maybe SectionTable) -readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfSectionTable logger dflags hdr bs = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF section table") return Nothing where @@ -245,15 +247,16 @@ data Section = Section } -- | Read a ELF section -readElfSectionByIndex :: DynFlags +readElfSectionByIndex :: Logger + -> DynFlags -> ElfHeader -> SectionTable -> Word64 -> ByteString -> IO (Maybe Section) -readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfSectionByIndex logger dflags hdr secTable i bs = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF section") return Nothing where @@ -289,13 +292,14 @@ readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do -- | Find a section from its name. Return the section contents. -- -- We do not perform any check on the section type. -findSectionFromName :: DynFlags +findSectionFromName :: Logger + -> DynFlags -> ElfHeader -> SectionTable -> String -> ByteString -> IO (Maybe ByteString) -findSectionFromName dflags hdr secTable name bs = +findSectionFromName logger dflags hdr secTable name bs = rec [0..sectionEntryCount secTable - 1] where -- convert the required section name into a ByteString to perform @@ -306,7 +310,7 @@ findSectionFromName dflags hdr secTable name bs = -- the matching one, if any rec [] = return Nothing rec (x:xs) = do - me <- readElfSectionByIndex dflags hdr secTable x bs + me <- readElfSectionByIndex logger dflags hdr secTable x bs case me of Just e | entryName e == name' -> return (Just (entryBS e)) _ -> rec xs @@ -316,20 +320,21 @@ findSectionFromName dflags hdr secTable name bs = -- -- If the section isn't found or if there is any parsing error, we return -- Nothing -readElfSectionByName :: DynFlags +readElfSectionByName :: Logger + -> DynFlags -> ByteString -> String -> IO (Maybe LBS.ByteString) -readElfSectionByName dflags bs name = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfSectionByName logger dflags bs name = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF section \"" ++ name ++ "\"") return Nothing where action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - secTable <- MaybeT $ readElfSectionTable dflags hdr bs - MaybeT $ findSectionFromName dflags hdr secTable name bs + hdr <- MaybeT $ readElfHeader logger dflags bs + secTable <- MaybeT $ readElfSectionTable logger dflags hdr bs + MaybeT $ findSectionFromName logger dflags hdr secTable name bs ------------------ -- NOTE SECTIONS @@ -339,14 +344,15 @@ readElfSectionByName 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 :: DynFlags +readElfNoteBS :: Logger + -> DynFlags -> ByteString -> String -> String -> IO (Maybe LBS.ByteString) -readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfNoteBS logger dflags bs sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF note \"" ++ noteId ++ "\" in section \"" ++ sectionName ++ "\"") return Nothing @@ -380,29 +386,30 @@ readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - sec <- MaybeT $ readElfSectionByName dflags bs sectionName + hdr <- MaybeT $ readElfHeader logger dflags bs + sec <- MaybeT $ readElfSectionByName logger dflags bs sectionName MaybeT $ runGetOrThrow (findNote hdr) sec -- | read a Note as a String -- -- 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 :: DynFlags +readElfNoteAsString :: Logger + -> DynFlags -> FilePath -> String -> String -> IO (Maybe String) -readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfNoteAsString logger dflags path sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF note \"" ++ noteId ++ "\" in section \"" ++ sectionName ++ "\"") return Nothing where action = do bs <- LBS.readFile path - note <- readElfNoteBS dflags bs sectionName noteId + note <- readElfNoteBS logger dflags bs sectionName noteId return (fmap B8.unpack note) diff --git a/compiler/GHC/SysTools/FileCleanup.hs b/compiler/GHC/SysTools/FileCleanup.hs index d8791e280c..1b73ad2812 100644 --- a/compiler/GHC/SysTools/FileCleanup.hs +++ b/compiler/GHC/SysTools/FileCleanup.hs @@ -12,6 +12,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Utils.Error import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Exception as Exception import GHC.Driver.Phases @@ -40,17 +41,17 @@ data TempFileLifetime -- runGhc(T) deriving (Show) -cleanTempDirs :: DynFlags -> IO () -cleanTempDirs dflags +cleanTempDirs :: Logger -> DynFlags -> IO () +cleanTempDirs logger dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = dirsToClean dflags ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) - removeTmpDirs dflags (Map.elems ds) + removeTmpDirs logger dflags (Map.elems ds) -- | Delete all files in @filesToClean dflags@. -cleanTempFiles :: DynFlags -> IO () -cleanTempFiles dflags +cleanTempFiles :: Logger -> DynFlags -> IO () +cleanTempFiles logger dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = filesToClean dflags @@ -60,21 +61,21 @@ cleanTempFiles dflags , ftcGhcSession = gs_files } -> ( emptyFilesToClean , Set.toList cm_files ++ Set.toList gs_files) - removeTmpFiles dflags to_delete + removeTmpFiles logger dflags to_delete -- | Delete all files in @filesToClean dflags@. That have lifetime -- TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. -cleanCurrentModuleTempFiles :: DynFlags -> IO () -cleanCurrentModuleTempFiles dflags +cleanCurrentModuleTempFiles :: Logger -> DynFlags -> IO () +cleanCurrentModuleTempFiles logger dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = filesToClean dflags to_delete <- atomicModifyIORef' ref $ \ftc@FilesToClean{ftcCurrentModule = cm_files} -> (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) - removeTmpFiles dflags to_delete + removeTmpFiles logger dflags to_delete -- | Ensure that new_files are cleaned on the next call of -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. @@ -117,9 +118,9 @@ newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n) -- Find a temporary name that doesn't already exist. -newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath -newTempName dflags lifetime extn - = do d <- getTempDir dflags +newTempName :: Logger -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath +newTempName logger dflags lifetime extn + = do d <- getTempDir logger dflags findTempName (d </> "ghc_") -- See Note [Deterministic base name] where findTempName :: FilePath -> IO FilePath @@ -132,9 +133,9 @@ newTempName dflags lifetime extn addFilesToClean dflags lifetime [filename] return filename -newTempDir :: DynFlags -> IO FilePath -newTempDir dflags - = do d <- getTempDir dflags +newTempDir :: Logger -> DynFlags -> IO FilePath +newTempDir logger dflags + = do d <- getTempDir logger dflags findTempDir (d </> "ghc_") where findTempDir :: FilePath -> IO FilePath @@ -147,10 +148,10 @@ newTempDir dflags -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename return filename -newTempLibName :: DynFlags -> TempFileLifetime -> Suffix +newTempLibName :: Logger -> DynFlags -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String) -newTempLibName dflags lifetime extn - = do d <- getTempDir dflags +newTempLibName logger dflags lifetime extn + = do d <- getTempDir logger dflags findTempName d ("ghc_") where findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) @@ -167,8 +168,8 @@ newTempLibName dflags lifetime extn -- Return our temporary directory within tmp_dir, creating one if we -- don't have one yet. -getTempDir :: DynFlags -> IO FilePath -getTempDir dflags = do +getTempDir :: Logger -> DynFlags -> IO FilePath +getTempDir logger dflags = do mapping <- readIORef dir_ref case Map.lookup tmp_dir mapping of Nothing -> do @@ -199,7 +200,7 @@ getTempDir dflags = do -- directory we created. Otherwise return the directory we created. case their_dir of Nothing -> do - debugTraceMsg dflags 2 $ + debugTraceMsg logger dflags 2 $ text "Created temporary directory:" <+> text our_dir return our_dir Just dir -> do @@ -219,18 +220,18 @@ the process id). This is ok, as the temporary directory used contains the pid (see getTempDir). -} -removeTmpDirs :: DynFlags -> [FilePath] -> IO () -removeTmpDirs dflags ds - = traceCmd dflags "Deleting temp dirs" +removeTmpDirs :: Logger -> DynFlags -> [FilePath] -> IO () +removeTmpDirs logger dflags ds + = traceCmd logger dflags "Deleting temp dirs" ("Deleting: " ++ unwords ds) - (mapM_ (removeWith dflags removeDirectory) ds) + (mapM_ (removeWith logger dflags removeDirectory) ds) -removeTmpFiles :: DynFlags -> [FilePath] -> IO () -removeTmpFiles dflags fs +removeTmpFiles :: Logger -> DynFlags -> [FilePath] -> IO () +removeTmpFiles logger dflags fs = warnNon $ - traceCmd dflags "Deleting temp files" + traceCmd logger dflags "Deleting temp files" ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith dflags removeFile) deletees) + (mapM_ (removeWith logger dflags 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 @@ -241,21 +242,21 @@ removeTmpFiles dflags fs warnNon act | null non_deletees = act | otherwise = do - putMsg dflags (text "WARNING - NOT deleting source files:" + putMsg logger dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees)) act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs -removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () -removeWith dflags remover f = remover f `catchIO` +removeWith :: Logger -> DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () +removeWith logger dflags remover f = remover f `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 dflags 2 msg + in debugTraceMsg logger dflags 2 msg ) #if defined(mingw32_HOST_OS) diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs index 89a81a7b7b..b53d0fb567 100644 --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -13,6 +13,7 @@ import GHC.Utils.Error import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Logger import Data.List ( isInfixOf, isPrefixOf ) import Data.IORef @@ -103,19 +104,19 @@ neededLinkArgs (AixLD o) = o neededLinkArgs UnknownLD = [] -- Grab linker info and cache it in DynFlags. -getLinkerInfo :: DynFlags -> IO LinkerInfo -getLinkerInfo dflags = do +getLinkerInfo :: Logger -> DynFlags -> IO LinkerInfo +getLinkerInfo logger dflags = do info <- readIORef (rtldInfo dflags) case info of Just v -> return v Nothing -> do - v <- getLinkerInfo' dflags + v <- getLinkerInfo' logger dflags writeIORef (rtldInfo dflags) (Just v) return v -- See Note [Run-time linker info]. -getLinkerInfo' :: DynFlags -> IO LinkerInfo -getLinkerInfo' dflags = do +getLinkerInfo' :: Logger -> DynFlags -> IO LinkerInfo +getLinkerInfo' logger dflags = do let platform = targetPlatform dflags os = platformOS platform (pgm,args0) = pgm_l dflags @@ -194,10 +195,10 @@ getLinkerInfo' dflags = do parseLinkerInfo (lines stdo) (lines stde) exitc ) (\err -> do - debugTraceMsg dflags 2 + debugTraceMsg logger dflags 2 (text "Error (figuring out linker information):" <+> text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ + errorMsg logger dflags $ 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." @@ -205,19 +206,19 @@ getLinkerInfo' dflags = do ) -- Grab compiler info and cache it in DynFlags. -getCompilerInfo :: DynFlags -> IO CompilerInfo -getCompilerInfo dflags = do +getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo +getCompilerInfo logger dflags = do info <- readIORef (rtccInfo dflags) case info of Just v -> return v Nothing -> do - v <- getCompilerInfo' dflags + v <- getCompilerInfo' logger dflags writeIORef (rtccInfo dflags) (Just v) return v -- See Note [Run-time linker info]. -getCompilerInfo' :: DynFlags -> IO CompilerInfo -getCompilerInfo' dflags = do +getCompilerInfo' :: Logger -> DynFlags -> IO CompilerInfo +getCompilerInfo' logger dflags = do let pgm = pgm_c dflags -- Try to grab the info from the process output. parseCompilerInfo _stdo stde _exitc @@ -251,10 +252,10 @@ getCompilerInfo' dflags = do parseCompilerInfo (lines stdo) (lines stde) exitc ) (\err -> do - debugTraceMsg dflags 2 + debugTraceMsg logger dflags 2 (text "Error (figuring out C compiler information):" <+> text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ + errorMsg logger dflags $ 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 62f3f0d258..df12cb4af7 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -18,7 +18,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Prelude import GHC.Utils.Misc -import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) +import GHC.Utils.Logger +import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import Control.Concurrent import Data.Char @@ -132,7 +133,8 @@ getGccEnv opts = ----------------------------------------------------------------------------- -- Running an external program -runSomething :: DynFlags +runSomething :: Logger + -> DynFlags -> String -- For -v message -> String -- Command name (possibly a full path) -- assumed already dos-ified @@ -140,8 +142,8 @@ runSomething :: DynFlags -- runSomething will dos-ify them -> IO () -runSomething dflags phase_name pgm args = - runSomethingFiltered dflags id phase_name pgm args Nothing Nothing +runSomething logger dflags phase_name pgm args = + runSomethingFiltered logger dflags id phase_name pgm args Nothing Nothing -- | Run a command, placing the arguments in an external response file. -- @@ -153,18 +155,18 @@ runSomething dflags phase_name pgm args = -- https://gcc.gnu.org/wiki/Response_Files -- https://gitlab.haskell.org/ghc/ghc/issues/10777 runSomethingResponseFile - :: DynFlags -> (String->String) -> String -> String -> [Option] + :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option] -> Maybe [(String,String)] -> IO () -runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = - runSomethingWith dflags phase_name pgm args $ \real_args -> do +runSomethingResponseFile logger dflags filter_fn phase_name pgm args mb_env = + runSomethingWith logger dflags phase_name pgm args $ \real_args -> do fp <- getResponseFile real_args let args = ['@':fp] - r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env + r <- builderMainLoop logger dflags filter_fn pgm args Nothing mb_env return (r,()) where getResponseFile args = do - fp <- newTempName dflags TFL_CurrentModule "rsp" + fp <- newTempName logger dflags TFL_CurrentModule "rsp" withFile fp WriteMode $ \h -> do #if defined(mingw32_HOST_OS) hSetEncoding h latin1 @@ -200,23 +202,23 @@ runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = ] runSomethingFiltered - :: DynFlags -> (String->String) -> String -> String -> [Option] + :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = - runSomethingWith dflags phase_name pgm args $ \real_args -> do - r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env +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 return (r,()) runSomethingWith - :: DynFlags -> String -> String -> [Option] + :: Logger -> DynFlags -> String -> String -> [Option] -> ([String] -> IO (ExitCode, a)) -> IO a -runSomethingWith dflags phase_name pgm args io = do +runSomethingWith logger dflags phase_name pgm args io = do let real_args = filter notNull (map showOpt args) cmdLine = showCommandForUser pgm real_args - traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args + traceCmd logger dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args handleProc :: String -> String -> IO (ExitCode, r) -> IO r handleProc pgm phase_name proc = do @@ -236,10 +238,10 @@ handleProc pgm phase_name proc = do does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) -builderMainLoop :: DynFlags -> (String -> String) -> FilePath +builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> IO ExitCode -builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do +builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do chan <- newChan -- We use a mask here rather than a bracket because we want @@ -300,11 +302,10 @@ builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do msg <- readChan chan case msg of BuildMsg msg -> do - putLogMsg dflags NoReason SevInfo noSrcSpan - $ withPprStyle defaultUserStyle msg + logInfo logger dflags $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do - putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) + putLogMsg logger dflags NoReason SevError (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 f71958f276..b802623325 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -24,6 +24,7 @@ import GHC.Utils.Exception as Exception import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Logger import Data.List (tails, isPrefixOf) import System.IO @@ -37,39 +38,39 @@ import System.Process ************************************************************************ -} -runUnlit :: DynFlags -> [Option] -> IO () -runUnlit dflags args = traceToolCommand dflags "unlit" $ do +runUnlit :: Logger -> DynFlags -> [Option] -> IO () +runUnlit logger dflags args = traceToolCommand logger dflags "unlit" $ do let prog = pgm_L dflags opts = getOpts dflags opt_L - runSomething dflags "Literate pre-processor" prog + runSomething logger dflags "Literate pre-processor" prog (map Option opts ++ args) -runCpp :: DynFlags -> [Option] -> IO () -runCpp dflags args = traceToolCommand dflags "cpp" $ do +runCpp :: Logger -> DynFlags -> [Option] -> IO () +runCpp logger dflags args = traceToolCommand logger dflags "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 dflags id "C pre-processor" p + runSomethingFiltered logger dflags id "C pre-processor" p (args0 ++ args1 ++ args2 ++ args) Nothing mb_env -runPp :: DynFlags -> [Option] -> IO () -runPp dflags args = traceToolCommand dflags "pp" $ do +runPp :: Logger -> DynFlags -> [Option] -> IO () +runPp logger dflags args = traceToolCommand logger dflags "pp" $ do let prog = pgm_F dflags opts = map Option (getOpts dflags opt_F) - runSomething dflags "Haskell pre-processor" prog (args ++ opts) + runSomething logger dflags "Haskell pre-processor" prog (args ++ opts) -- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO () -runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do +runCc :: Maybe ForeignSrcLang -> Logger -> DynFlags -> [Option] -> IO () +runCc mLanguage logger dflags args = traceToolCommand logger dflags "cc" $ do let p = pgm_c dflags args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 -- We take care to pass -optc flags in args1 last to ensure that the -- user can override flags passed by GHC. See #14452. mb_env <- getGccEnv args2 - runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env + runSomethingResponseFile logger dflags cc_filter "C Compiler" p args2 mb_env where -- discard some harmless warnings from gcc that we can't turn off cc_filter = unlines . doFilter . lines @@ -143,44 +144,44 @@ isContainedIn :: String -> String -> Bool xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) -- | Run the linker with some arguments and return the output -askLd :: DynFlags -> [Option] -> IO String -askLd dflags args = traceToolCommand dflags "linker" $ do +askLd :: Logger -> DynFlags -> [Option] -> IO String +askLd logger dflags args = traceToolCommand logger dflags "linker" $ do let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - runSomethingWith dflags "gcc" p args2 $ \real_args -> + runSomethingWith logger dflags "gcc" p args2 $ \real_args -> readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } -runAs :: DynFlags -> [Option] -> IO () -runAs dflags args = traceToolCommand dflags "as" $ do +runAs :: Logger -> DynFlags -> [Option] -> IO () +runAs logger dflags args = traceToolCommand logger dflags "as" $ do let (p,args0) = pgm_a dflags args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env + runSomethingFiltered logger dflags id "Assembler" p args2 Nothing mb_env -- | Run the LLVM Optimiser -runLlvmOpt :: DynFlags -> [Option] -> IO () -runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do +runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO () +runLlvmOpt logger dflags args = traceToolCommand logger dflags "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 dflags "LLVM Optimiser" p (args1 ++ args ++ args0) + runSomething logger dflags "LLVM Optimiser" p (args1 ++ args ++ args0) -- | Run the LLVM Compiler -runLlvmLlc :: DynFlags -> [Option] -> IO () -runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do +runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO () +runLlvmLlc logger dflags args = traceToolCommand logger dflags "llc" $ do let (p,args0) = pgm_lc dflags args1 = map Option (getOpts dflags opt_lc) - runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) + runSomething logger dflags "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 :: DynFlags -> [Option] -> IO () -runClang dflags args = traceToolCommand dflags "clang" $ do +runClang :: Logger -> DynFlags -> [Option] -> IO () +runClang logger dflags args = traceToolCommand logger dflags "clang" $ do let (clang,_) = pgm_lcc dflags -- be careful what options we call clang with -- see #5903 and #7617 for bugs caused by this. @@ -189,9 +190,9 @@ runClang dflags args = traceToolCommand dflags "clang" $ do args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 catch - (runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env) + (runSomethingFiltered logger dflags id "Clang (Assembler)" clang args2 Nothing mb_env) (\(err :: SomeException) -> do - errorMsg dflags $ + errorMsg logger dflags $ text ("Error running clang! you need clang installed to use the" ++ " LLVM backend") $+$ text "(or GHC tried to execute clang incorrectly)" @@ -199,8 +200,8 @@ runClang dflags args = traceToolCommand dflags "clang" $ do ) -- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) -figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do +figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) +figureLlvmVersion logger dflags = traceToolCommand logger dflags "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 @@ -226,10 +227,10 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do return mb_ver ) (\err -> do - debugTraceMsg dflags 2 + debugTraceMsg logger dflags 2 (text "Error (figuring out LLVM version):" <+> text (show err)) - errorMsg dflags $ vcat + errorMsg logger dflags $ vcat [ text "Warning:", nest 9 $ text "Couldn't figure out LLVM version!" $$ text ("Make sure you have installed LLVM " ++ @@ -238,19 +239,19 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do -runLink :: DynFlags -> [Option] -> IO () -runLink dflags args = traceToolCommand dflags "linker" $ do +runLink :: Logger -> DynFlags -> [Option] -> IO () +runLink logger dflags args = traceToolCommand logger dflags "linker" $ do -- See Note [Run-time linker info] -- -- `-optl` args come at the end, so that later `-l` options -- given there manually can fill in symbols needed by -- Haskell libraries coming in via `args`. - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags let (p,args0) = pgm_l dflags optl_args = map Option (getOpts dflags opt_l) args2 = args0 ++ linkargs ++ args ++ optl_args mb_env <- getGccEnv args2 - runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env + runSomethingResponseFile logger dflags ld_filter "Linker" p args2 mb_env where ld_filter = case (platformOS (targetPlatform dflags)) of OSSolaris2 -> sunos_ld_filter @@ -302,8 +303,8 @@ ld: warning: symbol referencing errors ld_warning_found = not . null . snd . ld_warn_break -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. -runMergeObjects :: DynFlags -> [Option] -> IO () -runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do +runMergeObjects :: Logger -> DynFlags -> [Option] -> IO () +runMergeObjects logger dflags args = traceToolCommand logger dflags "merge-objects" $ do let (p,args0) = pgm_lm dflags optl_args = map Option (getOpts dflags opt_lm) args2 = args0 ++ args ++ optl_args @@ -311,43 +312,43 @@ runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do -- use them on Windows where they are truly necessary. #if defined(mingw32_HOST_OS) mb_env <- getGccEnv args2 - runSomethingResponseFile dflags id "Merge objects" p args2 mb_env + runSomethingResponseFile logger dflags id "Merge objects" p args2 mb_env #else - runSomething dflags "Merge objects" p args2 + runSomething logger dflags "Merge objects" p args2 #endif -runLibtool :: DynFlags -> [Option] -> IO () -runLibtool dflags args = traceToolCommand dflags "libtool" $ do - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags +runLibtool :: Logger -> DynFlags -> [Option] -> IO () +runLibtool logger dflags args = traceToolCommand logger dflags "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 dflags id "Libtool" libtool args2 Nothing mb_env + runSomethingFiltered logger dflags id "Libtool" libtool args2 Nothing mb_env -runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr dflags cwd args = traceToolCommand dflags "ar" $ do +runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () +runAr logger dflags cwd args = traceToolCommand logger dflags "ar" $ do let ar = pgm_ar dflags - runSomethingFiltered dflags id "Ar" ar args cwd Nothing + runSomethingFiltered logger dflags id "Ar" ar args cwd Nothing -askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String -askOtool dflags mb_cwd args = do +askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String +askOtool logger dflags mb_cwd args = do let otool = pgm_otool dflags - runSomethingWith dflags "otool" otool args $ \real_args -> + runSomethingWith logger dflags "otool" otool args $ \real_args -> readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } -runInstallNameTool :: DynFlags -> [Option] -> IO () -runInstallNameTool dflags args = do +runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO () +runInstallNameTool logger dflags args = do let tool = pgm_install_name_tool dflags - runSomethingFiltered dflags id "Install Name Tool" tool args Nothing Nothing + runSomethingFiltered logger dflags id "Install Name Tool" tool args Nothing Nothing -runRanlib :: DynFlags -> [Option] -> IO () -runRanlib dflags args = traceToolCommand dflags "ranlib" $ do +runRanlib :: Logger -> DynFlags -> [Option] -> IO () +runRanlib logger dflags args = traceToolCommand logger dflags "ranlib" $ do let ranlib = pgm_ranlib dflags - runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing + runSomethingFiltered logger dflags id "Ranlib" ranlib args Nothing Nothing -runWindres :: DynFlags -> [Option] -> IO () -runWindres dflags args = traceToolCommand dflags "windres" $ do +runWindres :: Logger -> DynFlags -> [Option] -> IO () +runWindres logger dflags args = traceToolCommand logger dflags "windres" $ do let cc = pgm_c dflags cc_args = map Option (sOpt_c (settings dflags)) windres = pgm_windres dflags @@ -367,11 +368,11 @@ runWindres dflags args = traceToolCommand dflags "windres" $ do : Option "--use-temp-file" : args mb_env <- getGccEnv cc_args - runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env + runSomethingFiltered logger dflags id "Windres" windres args' Nothing mb_env -touch :: DynFlags -> String -> String -> IO () -touch dflags purpose arg = traceToolCommand dflags "touch" $ - runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] +touch :: Logger -> DynFlags -> String -> String -> IO () +touch logger dflags purpose arg = traceToolCommand logger dflags "touch" $ + runSomething logger dflags purpose (pgm_T dflags) [FileOption "" arg] -- * Tracing utility @@ -382,6 +383,6 @@ touch dflags purpose arg = traceToolCommand dflags "touch" $ -- -- For those events to show up in the eventlog, you need -- to run GHC with @-v2@ or @-ddump-timings@. -traceToolCommand :: DynFlags -> String -> IO a -> IO a -traceToolCommand dflags tool = withTiming +traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a +traceToolCommand logger dflags tool = withTiming logger dflags (text $ "systool:" ++ tool) (const ()) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index e3dec46f91..4d072fff5f 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -61,6 +61,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) @@ -199,6 +200,7 @@ tcDeriving deriv_infos deriv_decls ; insts2 <- mapM genInst infer_specs ; dflags <- getDynFlags + ; logger <- getLogger ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2) ; loc <- getSrcSpanM @@ -233,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 dflags Opt_D_dump_deriv "Derived instances" + liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Derived instances" FormatHaskell (ddump_deriving inst_info rn_binds famInsts)) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index e04f22be8f..61b09e27e0 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -119,6 +119,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic as Panic import GHC.Utils.Lexeme import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) ) @@ -1135,7 +1136,8 @@ instance TH.Quasi TcM where qAddTempFile suffix = do dflags <- getDynFlags - liftIO $ newTempName dflags TFL_GhcSession suffix + logger <- getLogger + liftIO $ newTempName logger dflags TFL_GhcSession suffix qAddTopDecls thds = do l <- getSrcSpanM diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 75a5bda5fe..084a98883d 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -128,6 +128,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.Name.Reader @@ -193,7 +194,7 @@ tcRnModule :: HscEnv tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} | RealSrcSpan real_loc _ <- loc - = withTiming dflags + = withTiming logger dflags (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ @@ -206,7 +207,8 @@ tcRnModule hsc_env mod_sum save_rn_syntax where hsc_src = ms_hsc_src mod_sum - dflags = hsc_dflags hsc_env + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env err_msg = mkPlainMsgEnvelope loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod @@ -296,7 +298,7 @@ tcRnModuleTcRnM hsc_env mod_sum tcRnSrcDecls explicit_mod_hdr local_decls export_ies ; whenM (goptM Opt_DoCoreLinting) $ - lintGblEnv (hsc_dflags hsc_env) tcg_env + lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env ; setGblEnv tcg_env $ do { -- Process the export list @@ -2889,7 +2891,7 @@ tcDump env -- Dump short output if -ddump-types or -ddump-tc when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types) + (dumpTcRn True Opt_D_dump_types "" FormatText (pprWithUnitState unit_state short_dump)) ; -- Dump bindings if -ddump-tc diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index d92d8e3d5c..bc9680c233 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -152,7 +152,6 @@ import qualified GHC.Core.TyCo.Rep as Rep -- this needs to be used only very lo import GHC.Core.Coercion import GHC.Core.Unify -import GHC.Utils.Error import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.TyCon @@ -168,6 +167,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Data.Bag as Bag import GHC.Types.Unique.Supply import GHC.Utils.Misc @@ -2986,7 +2986,7 @@ csTraceTcM mk_doc || dopt Opt_D_dump_tc_trace dflags ) ( do { msg <- mk_doc ; TcM.dumpTcRn False - (dumpOptionsFromFlag Opt_D_dump_cs_trace) + Opt_D_dump_cs_trace "" FormatText msg }) } {-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 469ef20778..2fb7c58101 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -71,6 +71,7 @@ import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Types.Id import GHC.Types.SourceText @@ -2056,6 +2057,7 @@ mkDefMethBind :: DFunId -> Class -> Id -> Name -- visible type application here mkDefMethBind dfun_id clas sel_id dm_name = do { dflags <- getDynFlags + ; logger <- getLogger ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag @@ -2072,7 +2074,7 @@ mkDefMethBind dfun_id clas sel_id dm_name bind = noLoc $ mkTopFunBind Generated fn $ [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" + ; liftIO (dumpIfSet_dyn logger dflags 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/Types.hs b/compiler/GHC/Tc/Types.hs index c7a78901f4..aad52c5d93 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -142,6 +142,7 @@ import GHC.Utils.Outputable import GHC.Utils.Fingerprint import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Builtin.Names ( isUnboundName ) @@ -236,6 +237,9 @@ data Env gbl lcl instance ContainsDynFlags (Env gbl lcl) where extractDynFlags env = hsc_dflags (env_top env) +instance ContainsLogger (Env gbl lcl) where + extractLogger env = hsc_logger (env_top env) + instance ContainsModule gbl => ContainsModule (Env gbl lcl) where extractModule env = extractModule (env_gbl env) @@ -1712,8 +1716,8 @@ getRoleAnnots bndrs role_env -- | Check the 'TcGblEnv' for consistency. Currently, only checks -- axioms, but should check other aspects, too. -lintGblEnv :: DynFlags -> TcGblEnv -> TcM () -lintGblEnv dflags tcg_env = - liftIO $ lintAxioms dflags (text "TcGblEnv axioms") axioms +lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM () +lintGblEnv logger dflags tcg_env = + liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms where axioms = typeEnvCoAxioms (tcg_type_env tcg_env) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 9a38a9c5be..066755e8f7 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -363,7 +363,7 @@ tcRnCheckUnit :: HscEnv -> Unit -> IO (Messages DecoratedSDoc, Maybe ()) tcRnCheckUnit hsc_env uid = - withTiming dflags + withTiming logger dflags (text "Check unit id" <+> ppr uid) (const ()) $ initTc hsc_env @@ -374,6 +374,7 @@ tcRnCheckUnit hsc_env uid = $ checkUnit uid where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) -- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... @@ -383,13 +384,14 @@ tcRnCheckUnit hsc_env uid = tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = - withTiming dflags + withTiming logger dflags (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 @@ -914,12 +916,13 @@ tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = - withTiming dflags + withTiming logger dflags (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] exportOccs = concatMap (map occName . availNames) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index c92da610fb..0c276d9e16 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -187,6 +187,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.Fixity.Env @@ -752,14 +753,14 @@ formatTraceMsg herald doc = hang (text herald) 2 doc traceOptTcRn :: DumpFlag -> SDoc -> TcRn () traceOptTcRn flag doc = whenDOptM flag $ - dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc + dumpTcRn False flag "" FormatText doc {-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] -- | Dump if the given 'DumpFlag' is set. dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpOptTcRn flag title fmt doc = whenDOptM flag $ - dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc + dumpTcRn False flag title fmt doc {-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities] -- | Unconditionally dump some trace output @@ -769,15 +770,16 @@ dumpOptTcRn flag title fmt doc = -- generally we want all other debugging output to use 'PprDump' -- style. We 'PprUser' style if 'useUserStyle' is True. -- -dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn () -dumpTcRn useUserStyle dumpOpt title fmt doc = do +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 $ dumpAction dflags sty dumpOpt title fmt real_doc + liftIO $ putDumpMsg logger dflags sty flag title fmt real_doc -- | Add current location if -dppr-debug -- (otherwise the full location is usually way too much) @@ -799,10 +801,11 @@ getPrintUnqualified -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () -printForUserTcRn doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified - ; liftIO (printOutputForUser dflags printer doc) } +printForUserTcRn doc = do + dflags <- getDynFlags + logger <- getLogger + printer <- getPrintUnqualified + liftIO (printOutputForUser logger dflags printer doc) {- traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is @@ -819,9 +822,10 @@ traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () traceOptIf flag doc - = whenDOptM flag $ -- No RdrEnv available, so qualify everything - do { dflags <- getDynFlags - ; liftIO (putMsg dflags doc) } + = whenDOptM flag $ do -- No RdrEnv available, so qualify everything + dflags <- getDynFlags + logger <- getLogger + liftIO (putMsg logger dflags doc) {-# INLINE traceOptIf #-} -- see Note [INLINE conditional tracing utilities] {- @@ -2058,13 +2062,14 @@ failIfM :: SDoc -> IfL a -- The Iface monad doesn't have a place to accumulate errors, so we -- just fall over fast if one happens; it "shouldn't happen". -- We use IfL here so that we can get context info out of the local env -failIfM msg - = do { env <- getLclEnv - ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; dflags <- getDynFlags - ; liftIO (putLogMsg dflags NoReason SevFatal - noSrcSpan $ withPprStyle defaultErrStyle full_msg) - ; failM } +failIfM msg = do + env <- getLclEnv + let full_msg = (if_loc env <> colon) $$ nest 2 msg + dflags <- getDynFlags + logger <- getLogger + liftIO (putLogMsg logger dflags NoReason SevFatal + noSrcSpan $ withPprStyle defaultErrStyle full_msg) + failM -------------------- @@ -2093,9 +2098,10 @@ forkM_maybe doc thing_inside -- 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 dflags + liftIO $ putLogMsg logger dflags NoReason SevFatal noSrcSpan diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index ba6277b182..cefa5e5058 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -98,8 +98,8 @@ import GHC.Data.Maybe import System.Environment ( getEnv ) import GHC.Data.FastString import qualified GHC.Data.ShortText as ST -import GHC.Utils.Error ( debugTraceMsg, dumpIfSet_dyn, - withTiming, DumpFormat (..) ) +import GHC.Utils.Logger +import GHC.Utils.Error import GHC.Utils.Exception import System.Directory @@ -573,18 +573,18 @@ listUnitInfo state = Map.elems (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit) -initUnits dflags cached_dbs = do +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit) +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 dflags -- printer for trace messages + let printer = debugTraceMsg logger dflags -- printer for trace messages - (unit_state,dbs) <- withTiming dflags (text "initializing unit database") + (unit_state,dbs) <- withTiming logger dflags (text "initializing unit database") forceUnitInfoMap $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs) - dumpIfSet_dyn dflags Opt_D_dump_mod_map "Module Map" + dumpIfSet_dyn logger dflags Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index d81577cb0b..e3a5ec6ed4 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -38,13 +38,6 @@ module GHC.Utils.Error ( doIfSet, doIfSet_dyn, getCaretDiagnostic, - -- * Dump files - dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, - dumpOptionsFromFlag, DumpOptions (..), - DumpFormat (..), DumpAction, dumpAction, defaultDumpAction, - TraceAction, traceAction, defaultTraceAction, - touchDumpFile, - -- * Issuing messages during compilation putMsg, printInfoForUser, printOutputForUser, logInfo, logOutput, @@ -52,7 +45,7 @@ module GHC.Utils.Error ( fatalErrorMsg, fatalErrorMsg'', compilationProgressMsg, showPass, - withTiming, withTimingSilent, withTimingD, withTimingSilentD, + withTiming, withTimingSilent, debugTraceMsg, ghcExit, prettyPrintGhcErrors, @@ -72,23 +65,18 @@ import GHC.Data.Bag import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc -import System.Directory import System.Exit ( ExitCode(..), exitWith ) -import System.FilePath ( takeDirectory, (</>) ) -import Data.List ( sortBy, stripPrefix ) -import qualified Data.Set as Set -import Data.IORef +import Data.List ( sortBy ) import Data.Maybe ( fromMaybe ) import Data.Function -import Data.Time import Debug.Trace import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch as MC (handle) -import System.IO import GHC.Conc ( getAllocationCounter ) import System.CPUTime @@ -152,10 +140,10 @@ sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList Nothing -> id Just err_limit -> take err_limit -ghcExit :: DynFlags -> Int -> IO () -ghcExit dflags val +ghcExit :: Logger -> DynFlags -> Int -> IO () +ghcExit logger dflags val | val == 0 = exitWith ExitSuccess - | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") + | otherwise = do errorMsg logger dflags (text "\nCompilation had errors\n\n") exitWith (ExitFailure val) doIfSet :: Bool -> IO () -> IO () @@ -167,180 +155,6 @@ doIfSet_dyn dflags flag action | gopt flag dflags = action | otherwise = return () -- ----------------------------------------------------------------------------- --- Dumping - -dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () -dumpIfSet dflags flag hdr doc - | not flag = return () - | otherwise = doDump dflags hdr doc -{-# INLINE dumpIfSet #-} -- see Note [INLINE conditional tracing utilities] - --- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated --- despite the fact that 'dumpIfSet' has an @INLINE@. -doDump :: DynFlags -> String -> SDoc -> IO () -doDump dflags hdr doc = - putLogMsg dflags - NoReason - SevDump - noSrcSpan - (withPprStyle defaultDumpStyle - (mkDumpDoc hdr doc)) - --- | A wrapper around 'dumpAction'. --- First check whether the dump flag is set --- Do nothing if it is unset -dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify -{-# INLINE dumpIfSet_dyn #-} -- see Note [INLINE conditional tracing utilities] - --- | A wrapper around 'dumpAction'. --- First check whether the dump flag is set --- Do nothing if it is unset --- --- Unlike 'dumpIfSet_dyn', has a printer argument -dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String - -> DumpFormat -> SDoc -> IO () -dumpIfSet_dyn_printer printer dflags flag hdr fmt doc - = when (dopt flag dflags) $ do - let sty = mkDumpStyle printer - dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc -{-# INLINE dumpIfSet_dyn_printer #-} -- see Note [INLINE conditional tracing utilities] - -mkDumpDoc :: String -> SDoc -> SDoc -mkDumpDoc hdr doc - = vcat [blankLine, - line <+> text hdr <+> line, - doc, - blankLine] - where - line = text (replicate 20 '=') - - --- | Ensure that a dump file is created even if it stays empty -touchDumpFile :: DynFlags -> DumpOptions -> IO () -touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ())) - --- | Run an action with the handle of a 'DumpFlag' if we are outputting to a --- file, otherwise 'Nothing'. -withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO () -withDumpFileHandle dflags dumpOpt action = do - let mFile = chooseDumpFile dflags dumpOpt - case mFile of - Just fileName -> do - let gdref = generatedDumps dflags - gd <- readIORef gdref - let append = Set.member fileName gd - mode = if append then AppendMode else WriteMode - unless append $ - writeIORef gdref (Set.insert fileName gd) - createDirectoryIfMissing True (takeDirectory fileName) - withFile fileName mode $ \handle -> do - -- We do not want the dump file to be affected by - -- environment variables, but instead to always use - -- UTF8. See: - -- https://gitlab.haskell.org/ghc/ghc/issues/10762 - hSetEncoding handle utf8 - - action (Just handle) - Nothing -> action Nothing - - --- | Write out a dump. --- If --dump-to-file is set then this goes to a file. --- otherwise emit to stdout. --- --- When @hdr@ is empty, we print in a more compact format (no separators and --- blank lines) -dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO () -dumpSDocWithStyle sty dflags dumpOpt hdr doc = - withDumpFileHandle dflags dumpOpt 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) - 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') - - -- write the dump to stdout - writeDump Nothing = do - let (doc', severity) - | null hdr = (doc, SevOutput) - | otherwise = (mkDumpDoc hdr doc, SevDump) - putLogMsg dflags NoReason severity noSrcSpan (withPprStyle sty doc') - - --- | Choose where to put a dump file based on DynFlags --- -chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath -chooseDumpFile dflags dumpOpt - - | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt - , Just prefix <- getPrefix - = Just $ setDir (prefix ++ dumpSuffix dumpOpt) - - | otherwise - = Nothing - - where getPrefix - -- dump file location is being forced - -- by the --ddump-file-prefix flag. - | Just prefix <- dumpPrefixForce dflags - = Just prefix - -- dump file location chosen by GHC.Driver.Pipeline.runPipeline - | Just prefix <- dumpPrefix dflags - = Just prefix - -- we haven't got a place to put a dump file. - | otherwise - = Nothing - setDir f = case dumpDir dflags of - Just d -> d </> f - Nothing -> f - --- | Dump options --- --- Dumps are printed on stdout by default except when the `dumpForcedToFile` --- field is set to True. --- --- When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are --- written into a file whose suffix is given in the `dumpSuffix` field. --- -data DumpOptions = DumpOptions - { dumpForcedToFile :: Bool -- ^ Must be dumped into a file, even if - -- -ddump-to-file isn't set - , dumpSuffix :: String -- ^ Filename suffix used when dumped into - -- a file - } - --- | Create dump options from a 'DumpFlag' -dumpOptionsFromFlag :: DumpFlag -> DumpOptions -dumpOptionsFromFlag Opt_D_th_dec_file = - DumpOptions -- -dth-dec-file dumps expansions of TH - { dumpForcedToFile = True -- splices into MODULE.th.hs even when - , dumpSuffix = "th.hs" -- -ddump-to-file isn't set - } -dumpOptionsFromFlag flag = - DumpOptions - { dumpForcedToFile = False - , dumpSuffix = suffix -- build a suffix from the flag name - } -- e.g. -ddump-asm => ".dump-asm" - where - str = show flag - suff = case stripPrefix "Opt_D_" str of - Just x -> x - Nothing -> panic ("Bad flag name: " ++ str) - suffix = map (\c -> if c == '_' then '-' else c) suff - - --- ----------------------------------------------------------------------------- -- Outputting messages from the compiler -- We want all messages to go through one place, so that we can @@ -354,32 +168,32 @@ ifVerbose dflags val act | otherwise = return () {-# INLINE ifVerbose #-} -- see Note [INLINE conditional tracing utilities] -errorMsg :: DynFlags -> SDoc -> IO () -errorMsg dflags msg - = putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg +errorMsg :: Logger -> DynFlags -> SDoc -> IO () +errorMsg logger dflags msg + = putLogMsg logger dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg -warningMsg :: DynFlags -> SDoc -> IO () -warningMsg dflags msg - = putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg +warningMsg :: Logger -> DynFlags -> SDoc -> IO () +warningMsg logger dflags msg + = putLogMsg logger dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg -fatalErrorMsg :: DynFlags -> SDoc -> IO () -fatalErrorMsg dflags msg = - putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg +fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO () +fatalErrorMsg logger dflags msg = + putLogMsg logger dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg -compilationProgressMsg :: DynFlags -> SDoc -> IO () -compilationProgressMsg dflags msg = do +compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO () +compilationProgressMsg logger dflags msg = do let str = showSDoc dflags msg traceEventIO $ "GHC progress: " ++ str ifVerbose dflags 1 $ - logOutput dflags $ withPprStyle defaultUserStyle msg + logOutput logger dflags $ withPprStyle defaultUserStyle msg -showPass :: DynFlags -> String -> IO () -showPass dflags what +showPass :: Logger -> DynFlags -> String -> IO () +showPass logger dflags what = ifVerbose dflags 2 $ - logInfo dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) + logInfo logger dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) data PrintTimings = PrintTimings | DontPrintTimings deriving (Eq, Show) @@ -409,26 +223,15 @@ data PrintTimings = PrintTimings | DontPrintTimings -- -- See Note [withTiming] for more. withTiming :: MonadIO m - => DynFlags -- ^ DynFlags + => 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 dflags what force action = - withTiming' dflags what force PrintTimings action - --- | Like withTiming but get DynFlags from the Monad. -withTimingD :: (MonadIO m, HasDynFlags m) - => 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 -withTimingD what force action = do - dflags <- getDynFlags - withTiming' dflags what force PrintTimings action - +withTiming logger dflags what force action = + withTiming' logger dflags what force PrintTimings action -- | Same as 'withTiming', but doesn't print timings in the -- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). @@ -436,45 +239,30 @@ withTimingD what force action = do -- See Note [withTiming] for more. withTimingSilent :: MonadIO m - => DynFlags -- ^ DynFlags + => 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 dflags what force action = - withTiming' dflags what force DontPrintTimings action - --- | Same as 'withTiming', but doesn't print timings in the --- console (when given @-vN@, @N >= 2@ or @-ddump-timings@) --- and gets the DynFlags from the given Monad. --- --- See Note [withTiming] for more. -withTimingSilentD - :: (MonadIO m, HasDynFlags m) - => 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 -withTimingSilentD what force action = do - dflags <- getDynFlags - withTiming' dflags what force DontPrintTimings action +withTimingSilent logger dflags what force action = + withTiming' logger dflags what force DontPrintTimings action -- | Worker for 'withTiming' and 'withTimingSilent'. withTiming' :: MonadIO m - => DynFlags -- ^ A means of getting a 'DynFlags' (often - -- 'getDynFlags' will work here) + => 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' dflags what force_result prtimings action +withTiming' logger dflags what force_result prtimings action = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags then do whenPrintTimings $ - logInfo dflags $ withPprStyle defaultUserStyle $ + logInfo logger dflags $ withPprStyle defaultUserStyle $ text "***" <+> what <> colon let ctx = initDefaultSDocContext dflags alloc0 <- liftIO getAllocationCounter @@ -492,7 +280,7 @@ withTiming' dflags what force_result prtimings action time = realToFrac (end - start) * 1e-9 when (verbosity dflags >= 2 && prtimings == PrintTimings) - $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle + $ liftIO $ logInfo logger dflags $ withPprStyle defaultUserStyle (text "!!!" <+> what <> colon <+> text "finished in" <+> doublePrec 2 time <+> text "milliseconds" @@ -502,7 +290,7 @@ withTiming' dflags what force_result prtimings action <+> text "megabytes") whenPrintTimings $ - dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText + dumpIfSet_dyn logger dflags Opt_D_dump_timings "" FormatText $ text $ showSDocOneLine ctx $ hsep [ what <> colon , text "alloc=" <> ppr alloc @@ -529,31 +317,31 @@ withTiming' 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 :: DynFlags -> Int -> SDoc -> IO () -debugTraceMsg dflags val msg = +debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO () +debugTraceMsg logger dflags val msg = ifVerbose dflags val $ - logInfo dflags (withPprStyle defaultDumpStyle msg) + logInfo logger dflags (withPprStyle defaultDumpStyle msg) {-# INLINE debugTraceMsg #-} -- see Note [INLINE conditional tracing utilities] -putMsg :: DynFlags -> SDoc -> IO () -putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg) +putMsg :: Logger -> DynFlags -> SDoc -> IO () +putMsg logger dflags msg = logInfo logger dflags (withPprStyle defaultUserStyle msg) -printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () -printInfoForUser dflags print_unqual msg - = logInfo dflags (withUserStyle print_unqual AllTheWay msg) +printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO () +printInfoForUser logger dflags print_unqual msg + = logInfo logger dflags (withUserStyle print_unqual AllTheWay msg) -printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () -printOutputForUser dflags print_unqual msg - = logOutput dflags (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) -logInfo :: DynFlags -> SDoc -> IO () -logInfo dflags msg - = putLogMsg dflags NoReason SevInfo noSrcSpan msg +logInfo :: Logger -> DynFlags -> SDoc -> IO () +logInfo logger dflags msg + = putLogMsg logger dflags NoReason SevInfo noSrcSpan msg -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' -logOutput :: DynFlags -> SDoc -> IO () -logOutput dflags msg - = putLogMsg dflags NoReason SevOutput noSrcSpan msg +logOutput :: Logger -> DynFlags -> SDoc -> IO () +logOutput logger dflags msg + = putLogMsg logger dflags NoReason SevOutput noSrcSpan msg prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags @@ -569,12 +357,12 @@ prettyPrintGhcErrors dflags where ctx = initSDocContext dflags defaultUserStyle -traceCmd :: DynFlags -> String -> String -> IO a -> IO a +traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a -- trace the command (at two levels of verbosity) -traceCmd dflags phase_name cmd_line action +traceCmd logger dflags phase_name cmd_line action = do { let verb = verbosity dflags - ; showPass dflags phase_name - ; debugTraceMsg dflags 3 (text cmd_line) + ; showPass logger dflags phase_name + ; debugTraceMsg logger dflags 3 (text cmd_line) ; case flushErr dflags of FlushErr io -> io @@ -582,8 +370,8 @@ traceCmd dflags phase_name cmd_line action ; action `catchIO` handle_exn verb } where - handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') - ; debugTraceMsg dflags 2 + handle_exn _verb exn = do { debugTraceMsg logger dflags 2 (char '\n') + ; debugTraceMsg logger dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn)) @@ -686,41 +474,3 @@ spent in each label). -} --- | Format of a dump --- --- Dump formats are loosely defined: dumps may contain various additional --- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint --- (e.g. for syntax highlighters). -data DumpFormat - = FormatHaskell -- ^ Haskell - | FormatCore -- ^ Core - | FormatSTG -- ^ STG - | FormatByteCode -- ^ ByteCode - | FormatCMM -- ^ Cmm - | FormatASM -- ^ Assembly code - | FormatC -- ^ C code/header - | FormatLLVM -- ^ LLVM bytecode - | FormatText -- ^ Unstructured dump - deriving (Show,Eq) - -type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String - -> DumpFormat -> SDoc -> IO () - -type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a - --- | Default action for 'dumpAction' hook -defaultDumpAction :: DumpAction -defaultDumpAction dflags sty dumpOpt title _fmt doc = - dumpSDocWithStyle sty dflags dumpOpt title doc - --- | Default action for 'traceAction' hook -defaultTraceAction :: TraceAction -defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc - --- | Helper for `dump_action` -dumpAction :: DumpAction -dumpAction dflags = dump_action dflags dflags - --- | Helper for `trace_action` -traceAction :: TraceAction -traceAction dflags = trace_action dflags dflags diff --git a/compiler/GHC/Utils/Error.hs-boot b/compiler/GHC/Utils/Error.hs-boot deleted file mode 100644 index a455e730f2..0000000000 --- a/compiler/GHC/Utils/Error.hs-boot +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module GHC.Utils.Error where - -import GHC.Prelude -import GHC.Utils.Outputable (SDoc, PprStyle ) -import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) - -type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String - -> DumpFormat -> SDoc -> IO () - -type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a - -data DumpOptions = DumpOptions - { dumpForcedToFile :: Bool - , dumpSuffix :: String - } - -data DumpFormat - = FormatHaskell - | FormatCore - | FormatSTG - | FormatByteCode - | FormatCMM - | FormatASM - | FormatC - | FormatLLVM - | FormatText - -defaultDumpAction :: DumpAction -defaultTraceAction :: TraceAction diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs new file mode 100644 index 0000000000..341d68b2e5 --- /dev/null +++ b/compiler/GHC/Utils/Logger.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE RankNTypes #-} + +-- | Logger +module GHC.Utils.Logger + ( Logger + , initLogger + , HasLogger (..) + , ContainsLogger (..) + , LogAction + , DumpAction + , TraceAction + , DumpFormat (..) + , putLogMsg + , putDumpMsg + , putTraceMsg + + -- * Hooks + , popLogHook + , pushLogHook + , popDumpHook + , pushDumpHook + , popTraceHook + , pushTraceHook + , makeThreadSafe + + -- * Logging + , jsonLogAction + , defaultLogAction + , defaultLogActionHPrintDoc + , defaultLogActionHPutStrDoc + + -- * Dumping + , defaultDumpAction + , withDumpFileHandle + , touchDumpFile + , dumpIfSet + , dumpIfSet_dyn + , dumpIfSet_dyn_printer + + -- * Tracing + , defaultTraceAction + ) +where + +import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Types.Error +import GHC.Types.SrcLoc + +import qualified GHC.Utils.Ppr as Pretty +import GHC.Utils.Outputable +import GHC.Utils.Json +import GHC.Utils.Panic + +import Data.IORef +import System.Directory +import System.FilePath ( takeDirectory, (</>) ) +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List +import Data.Time +import System.IO +import Control.Monad +import Control.Concurrent.MVar +import System.IO.Unsafe + +type LogAction = DynFlags + -> WarnReason + -> Severity + -> SrcSpan + -> SDoc + -> IO () + +type DumpAction = DynFlags + -> PprStyle + -> DumpFlag + -> String + -> DumpFormat + -> SDoc + -> IO () + +type TraceAction a = DynFlags -> String -> SDoc -> a -> a + +-- | Format of a dump +-- +-- Dump formats are loosely defined: dumps may contain various additional +-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint +-- (e.g. for syntax highlighters). +data DumpFormat + = FormatHaskell -- ^ Haskell + | FormatCore -- ^ Core + | FormatSTG -- ^ STG + | FormatByteCode -- ^ ByteCode + | FormatCMM -- ^ Cmm + | FormatASM -- ^ Assembly code + | FormatC -- ^ C code/header + | FormatLLVM -- ^ LLVM bytecode + | FormatText -- ^ Unstructured dump + deriving (Show,Eq) + +type DumpCache = IORef (Set FilePath) + +data Logger = Logger + { log_hook :: [LogAction -> LogAction] + -- ^ Log hooks stack + + , dump_hook :: [DumpAction -> DumpAction] + -- ^ Dump hooks stack + + , trace_hook :: forall a. [TraceAction a -> TraceAction a] + -- ^ Trace hooks stack + + , generated_dumps :: DumpCache + -- ^ Already dumped files (to append instead of overwriting them) + } + +initLogger :: IO Logger +initLogger = do + dumps <- newIORef Set.empty + return $ Logger + { log_hook = [] + , dump_hook = [] + , trace_hook = [] + , generated_dumps = dumps + } + +-- | Log something +putLogMsg :: Logger -> LogAction +putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) + +-- | Dump something +putDumpMsg :: Logger -> DumpAction +putDumpMsg logger = + let + fallback = putLogMsg logger + dumps = generated_dumps logger + deflt = defaultDumpAction dumps fallback + in foldr ($) deflt (dump_hook logger) + +-- | Trace something +putTraceMsg :: Logger -> TraceAction a +putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger) + + +-- | Push a log hook +pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger +pushLogHook h logger = logger { log_hook = h:log_hook logger } + +-- | Pop a log hook +popLogHook :: Logger -> Logger +popLogHook logger = case log_hook logger of + [] -> panic "popLogHook: empty hook stack" + _:hs -> logger { log_hook = hs } + +-- | Push a dump hook +pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger +pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } + +-- | Pop a dump hook +popDumpHook :: Logger -> Logger +popDumpHook logger = case dump_hook logger of + [] -> panic "popDumpHook: empty hook stack" + _:hs -> logger { dump_hook = hs } + +-- | Push a trace hook +pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger +pushTraceHook h logger = logger { trace_hook = h:trace_hook logger } + +-- | Pop a trace hook +popTraceHook :: Logger -> Logger +popTraceHook logger = case trace_hook logger of + [] -> panic "popTraceHook: empty hook stack" + _ -> logger { trace_hook = tail (trace_hook logger) } + +-- | Make the logger thread-safe +makeThreadSafe :: Logger -> IO Logger +makeThreadSafe logger = do + lock <- newMVar () + let + with_lock :: forall a. IO a -> IO a + with_lock act = withMVar lock (const act) + + log action dflags reason sev loc doc = + with_lock (action dflags reason sev loc doc) + + dmp action dflags sty opts str fmt doc = + with_lock (action dflags 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)) + + return $ pushLogHook log + $ pushDumpHook dmp + $ pushTraceHook trc + $ logger + +-- See Note [JSON Error Messages] +-- +jsonLogAction :: LogAction +jsonLogAction dflags reason severity srcSpan msg + = + defaultLogActionHPutStrDoc dflags True stdout + (withPprStyle (PprCode CStyle) (doc $$ text "")) + where + str = renderWithContext (initSDocContext dflags defaultUserStyle) msg + doc = renderJSON $ + JSObject [ ( "span", json srcSpan ) + , ( "doc" , JSString str ) + , ( "severity", json severity ) + , ( "reason" , json reason ) + ] + + +defaultLogAction :: LogAction +defaultLogAction dflags reason severity srcSpan msg + | dopt Opt_D_dump_json dflags = jsonLogAction dflags reason severity srcSpan msg + | otherwise = case severity of + SevOutput -> printOut msg + SevDump -> printOut (msg $$ blankLine) + SevInteractive -> putStrSDoc msg + SevInfo -> printErrs msg + SevFatal -> printErrs msg + SevWarning -> printWarns + SevError -> printWarns + where + printOut = defaultLogActionHPrintDoc dflags False stdout + printErrs = defaultLogActionHPrintDoc dflags False stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout + -- Pretty print the warning flag, if any (#10752) + message = mkLocMessageAnn flagMsg severity srcSpan msg + + printWarns = do + hPutChar stderr '\n' + caretDiagnostic <- + if gopt Opt_DiagnosticsShowCaret dflags + then getCaretDiagnostic severity srcSpan + else pure empty + printErrs $ getPprStyle $ \style -> + withPprStyle (setStyleColoured True style) + (message $+$ caretDiagnostic) + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + + flagMsg = + case reason of + NoReason -> Nothing + Reason wflag -> do + spec <- flagSpecOf wflag + return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) + ErrReason Nothing -> + return "-Werror" + ErrReason (Just wflag) -> do + spec <- flagSpecOf wflag + return $ + "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ + ", -Werror=" ++ flagSpecName spec + + warnFlagGrp flag + | gopt Opt_ShowWarnGroups dflags = + case smallestGroups 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 "") + +-- | 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 + -- 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 + +-- +-- Note [JSON Error Messages] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When the user requests the compiler output to be dumped as json +-- we used to collect them all in an IORef and then print them at the end. +-- This doesn't work very well with GHCi. (See #14078) So instead we now +-- use the simpler method of just outputting a JSON document inplace to +-- stdout. +-- +-- Before the compiler calls log_action, it has already turned the `ErrMsg` +-- into a formatted message. This means that we lose some possible +-- information to provide to the user but refactoring log_action is quite +-- invasive as it is called in many places. So, for now I left it alone +-- and we can refine its behaviour as users request different output. + +-- | 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 + +-- | Write out a dump. +-- +-- If --dump-to-file is set then this goes to a file. +-- otherwise emit to stdout (via the the LogAction parameter). +-- +-- 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 + 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) + 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') + + -- write the dump to stdout + writeDump Nothing = do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + log_action dflags NoReason severity 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 + case mFile of + Just fileName -> do + gd <- readIORef dumps + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + unless append $ + writeIORef dumps (Set.insert fileName gd) + createDirectoryIfMissing True (takeDirectory fileName) + withFile fileName mode $ \handle -> do + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://gitlab.haskell.org/ghc/ghc/issues/10762 + hSetEncoding handle utf8 + + 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 + , Just prefix <- getPrefix + = Just $ setDir (prefix ++ dump_suffix) + + | otherwise + = Nothing + where + (forced_to_file, dump_suffix) = case flag of + -- -dth-dec-file dumps expansions of TH + -- splices into MODULE.th.hs even when + -- -ddump-to-file isn't set + Opt_D_th_dec_file -> (True, "th.hs") + _ -> (False, default_suffix) + + -- build a suffix from the flag name + -- e.g. -ddump-asm => ".dump-asm" + default_suffix = map (\c -> if c == '_' then '-' else c) $ + let str = show flag + in case stripPrefix "Opt_D_" str of + Just x -> x + Nothing -> panic ("chooseDumpFile: bad flag name: " ++ str) + + getPrefix + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | Just prefix <- dumpPrefixForce dflags + = Just prefix + -- dump file location chosen by GHC.Driver.Pipeline.runPipeline + | Just prefix <- dumpPrefix dflags + = Just prefix + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + setDir f = case dumpDir dflags 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 + NoReason + SevDump + noSrcSpan + (withPprStyle defaultDumpStyle + (mkDumpDoc hdr doc)) + +mkDumpDoc :: String -> SDoc -> SDoc +mkDumpDoc hdr doc + = vcat [blankLine, + line <+> text hdr <+> line, + doc, + blankLine] + where + 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] + +-- | A wrapper around 'putDumpMsg'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +-- +-- Unlike 'dumpIfSet_dyn', has a printer argument +dumpIfSet_dyn_printer + :: PrintUnqualified + -> Logger + -> DynFlags + -> DumpFlag + -> String + -> DumpFormat + -> SDoc + -> IO () +dumpIfSet_dyn_printer printer logger dflags flag hdr fmt doc + = when (dopt flag dflags) $ do + let sty = mkDumpStyle printer + putDumpMsg logger dflags sty flag hdr fmt doc +{-# INLINE dumpIfSet_dyn_printer #-} -- 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 + + + +class HasLogger m where + getLogger :: m Logger + +class ContainsLogger t where + extractLogger :: t -> Logger + diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2264cb539b..3330dbc03d 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -705,6 +705,7 @@ Library GHC.Utils.IO.Unsafe GHC.Utils.Json GHC.Utils.Lexeme + GHC.Utils.Logger GHC.Utils.Misc GHC.Utils.Monad GHC.Utils.Monad.State diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 48886ea88f..7dc253b894 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -58,7 +58,7 @@ import GHC.Driver.Config import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Resume, SingleStep, Ghc, - GetDocsFailure(..), + GetDocsFailure(..), putLogMsgM, pushLogHookM, getModuleGraph, handleSourceError, ms_mod ) import GHC.Driver.Main (hscParseDeclsWithLocation, hscParseStmtWithLocation) import GHC.Hs.ImpExp @@ -86,6 +86,7 @@ import GHC.Unit.Module.ModSummary import GHC.Data.StringBuffer import GHC.Utils.Outputable +import GHC.Utils.Logger -- Other random utilities import GHC.Types.Basic hiding ( isTopLevel ) @@ -478,13 +479,10 @@ interactiveUI config srcs maybe_exprs = do $ dflags GHC.setInteractiveDynFlags dflags' + -- Update the LogAction. Ensure we don't override the user's log action lest + -- we break -ddump-json (#14078) lastErrLocationsRef <- liftIO $ newIORef [] - progDynFlags <- GHC.getProgramDynFlags - _ <- GHC.setProgramDynFlags $ - -- Ensure we don't override the user's log action lest we break - -- -ddump-json (#14078) - progDynFlags { log_action = ghciLogAction (log_action progDynFlags) - lastErrLocationsRef } + pushLogHookM (ghciLogAction lastErrLocationsRef) when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): @@ -576,8 +574,8 @@ resetLastErrorLocations = do st <- getGHCiState liftIO $ writeIORef (lastErrorLocations st) [] -ghciLogAction :: LogAction -> IORef [(FastString, Int)] -> LogAction -ghciLogAction old_log_action lastErrLocations +ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction +ghciLogAction lastErrLocations old_log_action dflags flag severity srcSpan msg = do old_log_action dflags flag severity srcSpan msg case severity of @@ -3014,10 +3012,11 @@ newDynFlags :: GhciMonad m => Bool -> [String] -> m () newDynFlags interactive_only minus_opts = do let lopts = map noLoc minus_opts + logger <- getLogger idflags0 <- GHC.getInteractiveDynFlags - (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts + (idflags1, leftovers, warns) <- GHC.parseDynamicFlags logger idflags0 lopts - liftIO $ handleFlagWarnings idflags1 warns + liftIO $ handleFlagWarnings logger idflags1 warns when (not $ null leftovers) (throwGhcException . CmdLineError $ "Some flags have not been recognized: " @@ -3031,7 +3030,7 @@ newDynFlags interactive_only minus_opts = do dflags0 <- getDynFlags when (not interactive_only) $ do - (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts + (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags logger dflags0 lopts must_reload <- GHC.setProgramDynFlags dflags1 -- if the package flags changed, reset the context and link @@ -3168,8 +3167,7 @@ showCmd str = do , action "bindings" $ showBindings , action "linker" $ do msg <- liftIO $ Loader.showLoaderState (hsc_loader hsc_env) - dflags <- getDynFlags - liftIO $ putLogMsg dflags NoReason SevDump noSrcSpan msg + putLogMsgM NoReason SevDump noSrcSpan msg , action "breaks" $ showBkptTable , action "context" $ showContext , action "packages" $ showUnits diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index b371a9b8b4..ed06d81d75 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -57,6 +57,7 @@ import GHCi.RemoteTypes import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl) import GHC.Hs.Utils import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch) import Numeric @@ -307,13 +308,20 @@ instance MonadIO GHCi where instance HasDynFlags GHCi where getDynFlags = getSessionDynFlags +instance HasLogger GHCi where + getLogger = hsc_logger <$> getSession + instance GhcMonad GHCi where setSession s' = liftGhc $ setSession s' getSession = liftGhc $ getSession + instance HasDynFlags (InputT GHCi) where getDynFlags = lift getDynFlags +instance HasLogger (InputT GHCi) where + getLogger = lift getLogger + instance GhcMonad (InputT GHCi) where setSession = lift . setSession getSession = lift getSession diff --git a/ghc/Main.hs b/ghc/Main.hs index 12acd5a479..a916820015 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -57,6 +57,7 @@ import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable import GHC.Utils.Monad ( liftIO ) import GHC.Utils.Binary ( openBinMem, put_ ) +import GHC.Utils.Logger import GHC.Settings.Config import GHC.Settings.Constants @@ -151,6 +152,8 @@ 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 -- the -fllvm and -fasm flags. If the default backend is not @@ -192,7 +195,7 @@ main' postLoadMode dflags0 args flagWarnings = do -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files (dflags3, fileish_args, dynamicFlagWarnings) <- - GHC.parseDynamicFlags dflags2 args + GHC.parseDynamicFlags logger dflags2 args let dflags4 = case bcknd of Interpreter | not (gopt Opt_ExternalInterpreter dflags3) -> @@ -215,7 +218,7 @@ main' postLoadMode dflags0 args flagWarnings = do handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do - liftIO $ handleFlagWarnings dflags4 flagWarnings' + liftIO $ handleFlagWarnings logger dflags4 flagWarnings' liftIO $ showBanner postLoadMode dflags4 @@ -252,7 +255,7 @@ main' postLoadMode dflags0 args flagWarnings = do DoFrontend f -> doFrontend f srcs DoBackpack -> doBackpack (map fst srcs) - liftIO $ dumpFinalStats dflags6 + liftIO $ dumpFinalStats logger dflags6 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () #if !defined(HAVE_INTERNAL_INTERPRETER) @@ -753,12 +756,12 @@ showUsage ghci dflags = do dump ('$':'$':s) = putStr progName >> dump s dump (c:s) = putChar c >> dump s -dumpFinalStats :: DynFlags -> IO () -dumpFinalStats dflags = - when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags +dumpFinalStats :: Logger -> DynFlags -> IO () +dumpFinalStats logger dflags = + when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats logger dflags -dumpFastStringStats :: DynFlags -> IO () -dumpFastStringStats dflags = do +dumpFastStringStats :: Logger -> DynFlags -> IO () +dumpFastStringStats logger dflags = do segments <- getFastStringTable hasZ <- getFastStringZEncCounter let buckets = concat segments @@ -779,14 +782,14 @@ dumpFastStringStats 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 dflags msg + putMsg logger dflags 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_dflags hsc_env) (pprUnits (hsc_units hsc_env)) -dumpUnitsSimple hsc_env = putMsg (hsc_dflags hsc_env) (pprUnitsSimple (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)) -- ----------------------------------------------------------------------------- -- Frontend plugin support diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs index 33b8b067ed..64800dd243 100644 --- a/testsuite/tests/callarity/unittest/CallArity1.hs +++ b/testsuite/tests/callarity/unittest/CallArity1.hs @@ -170,18 +170,19 @@ main = do runGhc (Just libdir) $ do getSessionDynFlags >>= setSessionDynFlags . flip gopt_set Opt_SuppressUniques dflags <- getSessionDynFlags + logger <- getLogger liftIO $ forM_ exprs $ \(n,e) -> do case lintExpr dflags [f,scrutf,scruta] e of - Just errs -> putMsg dflags (pprMessageBag errs $$ text "in" <+> text n) + Just errs -> putMsg logger dflags (pprMessageBag errs $$ text "in" <+> text n) Nothing -> return () - putMsg dflags (text n Outputable.<> char ':') + putMsg logger dflags (text n Outputable.<> char ':') -- liftIO $ putMsg dflags (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 dflags $ nest 4 $ ppr v <+> ppr (idCallArity v) + forM_ bndrs $ \v -> putMsg logger dflags $ nest 4 $ ppr v <+> ppr (idCallArity v) -- Utilities mkLApps :: Id -> [Integer] -> CoreExpr diff --git a/testsuite/tests/ghc-api/T10052/T10052.hs b/testsuite/tests/ghc-api/T10052/T10052.hs index 03a4a65d6e..f579c0641d 100644 --- a/testsuite/tests/ghc-api/T10052/T10052.hs +++ b/testsuite/tests/ghc-api/T10052/T10052.hs @@ -19,7 +19,8 @@ runGhc' args act = do flags = map noLoc (tail args) runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 flags + logger <- getLogger + (dflags1, _leftover, _warns) <- parseDynamicFlags logger dflags0 flags let dflags2 = dflags1 { backend = Interpreter , ghcLink = LinkInMemory diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs index a29dc194dd..e0b6a57764 100644 --- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs +++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs @@ -37,6 +37,7 @@ main = do `xopt_set` LangExt.RankNTypes hsc_env <- getSession let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env liftIO $ do th_t <- runQ [t| forall k {j}. forall (a :: k) (b :: j) -> @@ -48,7 +49,7 @@ main = do let (warnings, errors) = partitionMessages messages case mres of Nothing -> do - printBagOfErrors dflags warnings - printBagOfErrors dflags errors + printBagOfErrors logger dflags warnings + printBagOfErrors logger dflags errors Just (t, _) -> do putStrLn $ showSDoc dflags (debugPprType t) diff --git a/testsuite/tests/ghc-api/T7478/T7478.hs b/testsuite/tests/ghc-api/T7478/T7478.hs index 89fd61a22c..786a859644 100644 --- a/testsuite/tests/ghc-api/T7478/T7478.hs +++ b/testsuite/tests/ghc-api/T7478/T7478.hs @@ -19,8 +19,9 @@ compileInGhc :: [FilePath] -- ^ Targets compileInGhc targets handlerOutput = do -- Set flags flags0 <- getSessionDynFlags - let flags = flags0 {verbosity = 1, log_action = collectSrcError handlerOutput} + let flags = flags0 {verbosity = 1 } setSessionDynFlags flags + pushLogHookM (const (collectSrcError handlerOutput)) -- Set up targets. oldTargets <- getTargets let oldFiles = map fileFromTarget oldTargets diff --git a/testsuite/tests/ghc-api/apirecomp001/myghc.hs b/testsuite/tests/ghc-api/apirecomp001/myghc.hs index 03c57e93a5..76dd6511ba 100644 --- a/testsuite/tests/ghc-api/apirecomp001/myghc.hs +++ b/testsuite/tests/ghc-api/apirecomp001/myghc.hs @@ -23,7 +23,8 @@ main = do libdir : args <- getArgs runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags, _, _) <- parseDynamicFlags dflags0 + logger <- getLogger + (dflags, _, _) <- parseDynamicFlags logger dflags0 (map (mkGeneralLocated "on the commandline") args) setSessionDynFlags $ dflags { backend = NoBackend , ghcLink = LinkInMemory diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs index 180932bd18..9e03f925b6 100644 --- a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs +++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs @@ -22,7 +22,8 @@ main = do defaultErrorHandler defaultFatalMessager defaultFlushOut $ do dflags0 <- getSessionDynFlags - (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $ + logger <- getLogger + (dflags1, _, _) <- parseDynamicFlags logger dflags0 $ map noLoc $ [ "-i", "-i.", "-imydir" -- , "-v3" ] ++ args diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs index 4f0f4d33bb..bd6849a192 100644 --- a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs +++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs @@ -47,7 +47,8 @@ main = do runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $ + logger <- getLogger + (dflags1, _, _) <- parseDynamicFlags logger dflags0 $ map noLoc $ [ "-fno-diagnostics-show-caret" -- , "-v3" ] ++ args diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.hs b/testsuite/tests/ghc-api/target-contents/TargetContents.hs index 4d8ecf1596..e6be1befd5 100644 --- a/testsuite/tests/ghc-api/target-contents/TargetContents.hs +++ b/testsuite/tests/ghc-api/target-contents/TargetContents.hs @@ -30,7 +30,8 @@ main = do createDirectoryIfMissing False "outdir" runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags1, xs, warn) <- parseDynamicFlags dflags0 $ map noLoc $ + logger <- getLogger + (dflags1, xs, warn) <- parseDynamicFlags logger dflags0 $ map noLoc $ [ "-outputdir", "./outdir" , "-fno-diagnostics-show-caret" ] ++ args diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout index 8c96acf235..84819595a6 100644 --- a/testsuite/tests/parser/should_run/CountAstDeps.stdout +++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout @@ -1,4 +1,4 @@ -Found 238 Language.Haskell.Syntax module dependencies +Found 239 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -222,6 +222,7 @@ GHC.Utils.GlobalVars GHC.Utils.IO.Unsafe GHC.Utils.Json GHC.Utils.Lexeme +GHC.Utils.Logger GHC.Utils.Misc GHC.Utils.Monad GHC.Utils.Outputable diff --git a/testsuite/tests/parser/should_run/CountDeps.hs b/testsuite/tests/parser/should_run/CountDeps.hs index df483c3ff1..43a5c58f9f 100644 --- a/testsuite/tests/parser/should_run/CountDeps.hs +++ b/testsuite/tests/parser/should_run/CountDeps.hs @@ -27,7 +27,8 @@ calcDeps modName libdir = defaultErrorHandler defaultFatalMessager defaultFlushOut $ do runGhc (Just libdir) $ do df <- getSessionDynFlags - (df, _, _) <- parseDynamicFlags df [noLoc "-package=ghc"] + logger <- getLogger + (df, _, _) <- parseDynamicFlags logger df [noLoc "-package=ghc"] setSessionDynFlags df env <- getSession loop env emptyUniqSet [mkModuleName modName] diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index 81d67c92ae..a7fe9c604e 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 246 GHC.Parser module dependencies +Found 247 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -230,6 +230,7 @@ GHC.Utils.GlobalVars GHC.Utils.IO.Unsafe GHC.Utils.Json GHC.Utils.Lexeme +GHC.Utils.Logger GHC.Utils.Misc GHC.Utils.Monad GHC.Utils.Outputable diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index fee1302b8e..afc6fa0fca 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -64,9 +64,10 @@ main = do --get a GHC context and run the tests runGhc (Just libdir) $ do dflags <- fmap setOptions getDynFlags + logger <- getLogger reifyGhc $ \_ -> do us <- unitTestUniqSupply - runTests dflags us + runTests logger dflags us return () @@ -100,6 +101,7 @@ assertIO = assertOr $ \msg -> void (throwIO . RegAllocTestException $ msg) -- ***NOTE*** This function sets Opt_D_dump_asm_stats in the passed -- DynFlags because it won't work without it. Handle stderr appropriately. compileCmmForRegAllocStats :: + Logger -> DynFlags -> FilePath -> (NCGConfig -> @@ -107,7 +109,7 @@ compileCmmForRegAllocStats :: UniqSupply -> IO [( Maybe [Color.RegAllocStats (Alignment, RawCmmStatics) X86.Instr.Instr] , Maybe [Linear.RegAllocStats])] -compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do +compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do let ncgImpl = ncgImplF (initNCGConfig dflags thisMod) hscEnv <- newHscEnv dflags @@ -117,18 +119,18 @@ compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do errorMsgs = fmap pprError errors -- print parser errors or warnings - mapM_ (printBagOfErrors dflags) [warningMsgs, errorMsgs] + mapM_ (printBagOfErrors logger dflags) [warningMsgs, errorMsgs] let initTopSRT = emptySRT thisMod cmmGroup <- fmap snd $ cmmPipeline hscEnv initTopSRT $ fromJust parsedCmm - rawCmms <- cmmToRawCmm dflags (Stream.yield cmmGroup) + rawCmms <- cmmToRawCmm logger dflags (Stream.yield cmmGroup) collectedCmms <- mconcat <$> Stream.collect rawCmms -- compile and discard the generated code, returning regalloc stats mapM (\ (count, thisCmm) -> - cmmNativeGen dflags thisModLoc ncgImpl + cmmNativeGen logger dflags thisModLoc ncgImpl usb dwarfFileIds dbgMap thisCmm count >>= (\(_, _, _, _, colorStats, linearStats, _) -> -- scrub unneeded output from cmmNativeGen @@ -160,8 +162,8 @@ noSpillsCmmFile = "no_spills.cmm" -- | Run each unit test in this file and notify the user of success or -- failure. -runTests :: DynFlags -> UniqSupply -> IO () -runTests dflags us = testGraphNoSpills dflags noSpillsCmmFile us >>= \res -> +runTests :: Logger -> DynFlags -> UniqSupply -> IO () +runTests logger dflags us = testGraphNoSpills logger dflags noSpillsCmmFile us >>= \res -> if res then putStrLn "All tests passed." else hPutStr stderr "testGraphNoSpills failed!" @@ -177,10 +179,10 @@ runTests dflags us = testGraphNoSpills dflags noSpillsCmmFile us >>= \res -> -- the register allocator should be able to do everything -- (on x86) in the passed file without any spills or reloads. -- -testGraphNoSpills :: DynFlags -> FilePath -> UniqSupply -> IO Bool -testGraphNoSpills dflags' path us = do +testGraphNoSpills :: Logger -> DynFlags -> FilePath -> UniqSupply -> IO Bool +testGraphNoSpills logger dflags' path us = do colorStats <- fst . concatTupledMaybes <$> - compileCmmForRegAllocStats dflags path X86.ncgX86 us + compileCmmForRegAllocStats logger dflags path X86.ncgX86 us assertIO "testGraphNoSpills: color stats should not be empty" $ not (null colorStats) diff --git a/utils/haddock b/utils/haddock -Subproject 010f0320dff64e3f86091ba4691bc69ce699964 +Subproject d1b7f181b60ba3ac191183f1512e66793d28ac0 |