module GHC.SysTools.Tasks where
import GHC.Prelude
import GHC.Platform
import GHC.ForeignSrcLang
import GHC.IO (catchException)
import GHC.CmmToLlvm.Base (llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)
import GHC.CmmToLlvm.Config (LlvmVersion)
import GHC.SysTools.Process
import GHC.SysTools.Info
import GHC.Driver.Session
import GHC.Utils.Exception as Exception
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Utils.Constants (isWindowsHost)
import GHC.Utils.Panic
import Data.List (tails, isPrefixOf)
import Data.Maybe (fromMaybe)
import System.IO
import System.Process
runUnlit :: Logger -> DynFlags -> [Option] -> IO ()
runUnlit logger dflags args = traceToolCommand logger "unlit" $ do
let prog = pgm_L dflags
opts = getOpts dflags opt_L
runSomething logger "Literate pre-processor" prog
(map Option opts ++ args)
augmentImports :: DynFlags -> [FilePath] -> [FilePath]
augmentImports dflags fps | Nothing <- workingDirectory dflags = fps
augmentImports _ [] = []
augmentImports _ [x] = [x]
augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp : augmentImports dflags fps
augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)
runCpp :: Logger -> DynFlags -> [Option] -> IO ()
runCpp logger dflags args = traceToolCommand logger "cpp" $ do
let opts = getOpts dflags opt_P
modified_imports = augmentImports dflags opts
let (p,args0) = pgm_P dflags
args1 = map Option modified_imports
args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
mb_env <- getGccEnv args2
runSomethingFiltered logger id "C pre-processor" p
(args0 ++ args1 ++ args2 ++ args) Nothing mb_env
runPp :: Logger -> DynFlags -> [Option] -> IO ()
runPp logger dflags args = traceToolCommand logger "pp" $ do
let prog = pgm_F dflags
opts = map Option (getOpts dflags opt_F)
runSomething logger "Haskell pre-processor" prog (args ++ opts)
runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runCc mLanguage logger tmpfs dflags args = traceToolCommand logger "cc" $ do
let args1 = map Option userOpts
args2 = languageOptions ++ args ++ args1
mb_env <- getGccEnv args2
runSomethingResponseFile logger tmpfs dflags cc_filter dbgstring prog args2
mb_env
where
cc_filter = unlines . doFilter . lines
doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
chunkWarnings :: [String]
-> [String]
-> [([String], [String])]
chunkWarnings loc_stack [] = [(loc_stack, [])]
chunkWarnings loc_stack xs
= case break loc_stack_start xs of
(warnings, lss:xs') ->
case span loc_start_continuation xs' of
(lsc, xs'') ->
(loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
_ -> [(loc_stack, xs)]
filterWarnings :: [([String], [String])] -> [([String], [String])]
filterWarnings [] = []
filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
[] -> filterWarnings zs
ys' -> (xs, ys') : filterWarnings zs
unChunkWarnings :: [([String], [String])] -> [String]
unChunkWarnings [] = []
unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
loc_stack_start s = "In file included from " `isPrefixOf` s
loc_start_continuation s = " from " `isPrefixOf` s
wantedWarning w
| "warning: call-clobbered register used" `isContainedIn` w = False
| otherwise = True
(languageOptions, userOpts, prog, dbgstring) = case mLanguage of
Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler")
Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr)
where
(languageName, opts, prog, dbgstr) = case language of
LangC -> ("c", userOpts_c
,pgm_c dflags, "C Compiler")
LangCxx -> ("c++", userOpts_cxx
,pgm_cxx dflags , "C++ Compiler")
LangObjc -> ("objective-c", userOpts_c
,pgm_c dflags , "Objective C Compiler")
LangObjcxx -> ("objective-c++", userOpts_cxx
,pgm_cxx dflags, "Objective C++ Compiler")
LangAsm -> ("assembler", []
,pgm_c dflags, "Asm Compiler")
RawObject -> ("c", []
,pgm_c dflags, "C Compiler")
userOpts_c = getOpts dflags opt_c
userOpts_cxx = getOpts dflags opt_cxx
isContainedIn :: String -> String -> Bool
xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
askLd :: Logger -> DynFlags -> [Option] -> IO String
askLd logger dflags args = traceToolCommand logger "linker" $ do
let (p,args0) = pgm_l dflags
args1 = map Option (getOpts dflags opt_l)
args2 = args0 ++ args1 ++ args
mb_env <- getGccEnv args2
runSomethingWith logger "gcc" p args2 $ \real_args ->
readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
runAs :: Logger -> DynFlags -> [Option] -> IO ()
runAs logger dflags args = traceToolCommand logger "as" $ do
let (p,args0) = pgm_a dflags
args1 = map Option (getOpts dflags opt_a)
args2 = args0 ++ args1 ++ args
mb_env <- getGccEnv args2
runSomethingFiltered logger id "Assembler" p args2 Nothing mb_env
runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()
runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do
let (p,args0) = pgm_lo dflags
args1 = map Option (getOpts dflags opt_lo)
runSomething logger "LLVM Optimiser" p (args1 ++ args ++ args0)
runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()
runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do
let (p,args0) = pgm_lc dflags
args1 = map Option (getOpts dflags opt_lc)
runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args)
runClang :: Logger -> DynFlags -> [Option] -> IO ()
runClang logger dflags args = traceToolCommand logger "clang" $ do
let (clang,_) = pgm_lcc dflags
(_,args0) = pgm_a dflags
args1 = map Option (getOpts dflags opt_a)
args2 = args0 ++ args1 ++ args
mb_env <- getGccEnv args2
catchException
(runSomethingFiltered logger id "Clang (Assembler)" clang args2 Nothing mb_env)
(\(err :: SomeException) -> do
errorMsg logger $
text ("Error running clang! you need clang installed to use the" ++
" LLVM backend") $+$
text "(or GHC tried to execute clang incorrectly)"
throwIO err
)
figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do
let (pgm,opts) = pgm_lc dflags
args = filter notNull (map showOpt opts)
args' = args ++ ["-version"]
catchIO (do
(pin, pout, perr, p) <- runInteractiveProcess pgm args'
Nothing Nothing
hSetBinaryMode pout False
_ <- hGetLine pout
vline <- hGetLine pout
let mb_ver = parseLlvmVersion vline
hClose pin
hClose pout
hClose perr
_ <- waitForProcess p
return mb_ver
)
(\err -> do
debugTraceMsg logger 2
(text "Error (figuring out LLVM version):" <+>
text (show err))
errorMsg logger $ vcat
[ text "Warning:", nest 9 $
text "Couldn't figure out LLVM version!" $$
text ("Make sure you have installed LLVM between ["
++ llvmVersionStr supportedLlvmVersionLowerBound
++ " and "
++ llvmVersionStr supportedLlvmVersionUpperBound
++ ")") ]
return Nothing)
runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do
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 logger tmpfs dflags ld_filter "Linker" p args2 mb_env
where
ld_filter = case (platformOS (targetPlatform dflags)) of
OSSolaris2 -> sunos_ld_filter
_ -> id
sunos_ld_filter :: String -> String
sunos_ld_filter = unlines . sunos_ld_filter' . lines
sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
then (ld_prefix x) ++ (ld_postfix x)
else x
breakStartsWith x y = break (isPrefixOf x) y
ld_prefix = fst . breakStartsWith "Undefined"
undefined_found = not . null . snd . breakStartsWith "Undefined"
ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
ld_postfix = tail . snd . ld_warn_break
ld_warning_found = not . null . snd . ld_warn_break
runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runMergeObjects logger tmpfs dflags args =
traceToolCommand logger "merge-objects" $ do
let (p,args0) = fromMaybe err (pgm_lm dflags)
err = throwGhcException $ UsageError $ unwords
[ "Attempted to merge object files but the configured linker"
, "does not support object merging." ]
optl_args = map Option (getOpts dflags opt_lm)
args2 = args0 ++ args ++ optl_args
if isWindowsHost
then do
mb_env <- getGccEnv args2
runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env
else do
runSomething logger "Merge objects" p args2
runLibtool :: Logger -> DynFlags -> [Option] -> IO ()
runLibtool logger dflags args = traceToolCommand logger "libtool" $ do
linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags
let args1 = map Option (getOpts dflags opt_l)
args2 = [Option "-static"] ++ args1 ++ args ++ linkargs
libtool = pgm_libtool dflags
mb_env <- getGccEnv args2
runSomethingFiltered logger id "Libtool" libtool args2 Nothing mb_env
runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()
runAr logger dflags cwd args = traceToolCommand logger "ar" $ do
let ar = pgm_ar dflags
runSomethingFiltered logger id "Ar" ar args cwd Nothing
askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String
askOtool logger dflags mb_cwd args = do
let otool = pgm_otool dflags
runSomethingWith logger "otool" otool args $ \real_args ->
readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }
runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()
runInstallNameTool logger dflags args = do
let tool = pgm_install_name_tool dflags
runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing
runRanlib :: Logger -> DynFlags -> [Option] -> IO ()
runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do
let ranlib = pgm_ranlib dflags
runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing
runWindres :: Logger -> DynFlags -> [Option] -> IO ()
runWindres logger dflags args = traceToolCommand logger "windres" $ do
let cc_args = map Option (sOpt_c (settings dflags))
windres = pgm_windres dflags
opts = map Option (getOpts dflags opt_windres)
mb_env <- getGccEnv cc_args
runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env
touch :: Logger -> DynFlags -> String -> String -> IO ()
touch logger dflags purpose arg = traceToolCommand logger "touch" $
runSomething logger purpose (pgm_T dflags) [FileOption "" arg]
traceToolCommand :: Logger -> String -> IO a -> IO a
traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ())