diff options
Diffstat (limited to 'compiler/GHC/SysTools/Tasks.hs')
| -rw-r--r-- | compiler/GHC/SysTools/Tasks.hs | 129 |
1 files changed, 65 insertions, 64 deletions
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 ()) |