From 8e2f85f6b4662676f0d7addaff9bf2c7d751bb63 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 7 Jan 2021 14:25:15 +0100 Subject: 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 --- compiler/GHC/SysTools/Elf.hs | 61 +++++++++-------- compiler/GHC/SysTools/FileCleanup.hs | 67 +++++++++--------- compiler/GHC/SysTools/Info.hs | 29 ++++---- compiler/GHC/SysTools/Process.hs | 43 ++++++------ compiler/GHC/SysTools/Tasks.hs | 129 ++++++++++++++++++----------------- 5 files changed, 170 insertions(+), 159 deletions(-) (limited to 'compiler/GHC/SysTools') 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 ()) -- cgit v1.2.1