module GHC.SysTools.Tasks where
import GHC.Utils.Exception as Exception
import GHC.Utils.Error
import GHC.Driver.Types
import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Platform
import GHC.Utils.Misc
import Data.List
import System.IO
import System.Process
import GHC.Prelude
import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion)
import GHC.SysTools.Process
import GHC.SysTools.Info
import Control.Monad (join, forM, filterM)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
runUnlit :: DynFlags -> [Option] -> IO ()
runUnlit dflags args = traceToolCommand dflags "unlit" $ do
let prog = pgm_L dflags
opts = getOpts dflags opt_L
runSomething dflags "Literate pre-processor" prog
(map Option opts ++ args)
runCpp :: DynFlags -> [Option] -> IO ()
runCpp dflags args = traceToolCommand 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
(args0 ++ args1 ++ args2 ++ args) Nothing mb_env
runPp :: DynFlags -> [Option] -> IO ()
runPp dflags args = traceToolCommand dflags "pp" $ do
let prog = pgm_F dflags
opts = map Option (getOpts dflags opt_F)
runSomething dflags "Haskell pre-processor" prog (args ++ opts)
runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do
let p = pgm_c dflags
args1 = map Option userOpts
args2 = languageOptions ++ args ++ args1
mb_env <- getGccEnv args2
runSomethingResponseFile dflags cc_filter "C Compiler" p 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) = case mLanguage of
Nothing -> ([], userOpts_c)
Just language -> ([Option "-x", Option languageName], opts)
where
(languageName, opts) = case language of
LangC -> ("c", userOpts_c)
LangCxx -> ("c++", userOpts_cxx)
LangObjc -> ("objective-c", userOpts_c)
LangObjcxx -> ("objective-c++", userOpts_cxx)
LangAsm -> ("assembler", [])
RawObject -> ("c", [])
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 :: DynFlags -> [Option] -> IO String
askLd dflags args = traceToolCommand 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 ->
readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
runAs :: DynFlags -> [Option] -> IO ()
runAs dflags args = traceToolCommand 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
runLlvmOpt :: DynFlags -> [Option] -> IO ()
runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do
let (p,args0) = pgm_lo dflags
args1 = map Option (getOpts dflags opt_lo)
runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0)
runLlvmLlc :: DynFlags -> [Option] -> IO ()
runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do
let (p,args0) = pgm_lc dflags
args1 = map Option (getOpts dflags opt_lc)
runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
runClang :: DynFlags -> [Option] -> IO ()
runClang dflags args = traceToolCommand dflags "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
catch (do
runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env
)
(\(err :: SomeException) -> do
errorMsg dflags $
text ("Error running clang! you need clang installed to use the" ++
" LLVM backend") $+$
text "(or GHC tried to execute clang incorrectly)"
throwIO err
)
figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do
let (pgm,opts) = pgm_lc dflags
args = filter notNull (map showOpt opts)
args' = args ++ ["-version"]
catchIO (do
(pin, pout, perr, _) <- runInteractiveProcess pgm args'
Nothing Nothing
hSetBinaryMode pout False
_ <- hGetLine pout
vline <- hGetLine pout
let mb_ver = parseLlvmVersion vline
hClose pin
hClose pout
hClose perr
return mb_ver
)
(\err -> do
debugTraceMsg dflags 2
(text "Error (figuring out LLVM version):" <+>
text (show err))
errorMsg dflags $ vcat
[ text "Warning:", nest 9 $
text "Couldn't figure out LLVM version!" $$
text ("Make sure you have installed LLVM " ++
llvmVersionStr supportedLlvmVersion) ]
return Nothing)
runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
runInjectRPaths dflags lib_paths dylib = do
info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib]
let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib]
let paths = concatMap f info
where f ("path":p:_) = [p]
f _ = []
lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')
case rpaths of
[] -> return ()
_ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
runLink :: DynFlags -> [Option] -> IO ()
runLink dflags args = traceToolCommand dflags "linker" $ do
linkargs <- neededLinkArgs `fmap` getLinkerInfo 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
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 :: DynFlags -> [Option] -> IO ()
runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do
let (p,args0) = pgm_lm dflags
optl_args = map Option (getOpts dflags opt_lm)
args2 = args0 ++ args ++ optl_args
#if defined(mingw32_HOST_OS)
mb_env <- getGccEnv args2
runSomethingResponseFile dflags id "Merge objects" p args2 mb_env
#else
runSomething dflags "Merge objects" p args2
#endif
runLibtool :: DynFlags -> [Option] -> IO ()
runLibtool dflags args = traceToolCommand dflags "libtool" $ do
linkargs <- neededLinkArgs `fmap` getLinkerInfo 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
runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()
runAr dflags cwd args = traceToolCommand dflags "ar" $ do
let ar = pgm_ar dflags
runSomethingFiltered dflags id "Ar" ar args cwd Nothing
askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String
askOtool dflags mb_cwd args = do
let otool = pgm_otool dflags
runSomethingWith dflags "otool" otool args $ \real_args ->
readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }
runInstallNameTool :: DynFlags -> [Option] -> IO ()
runInstallNameTool dflags args = do
let tool = pgm_install_name_tool dflags
runSomethingFiltered dflags id "Install Name Tool" tool args Nothing Nothing
runRanlib :: DynFlags -> [Option] -> IO ()
runRanlib dflags args = traceToolCommand dflags "ranlib" $ do
let ranlib = pgm_ranlib dflags
runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing
runWindres :: DynFlags -> [Option] -> IO ()
runWindres dflags args = traceToolCommand dflags "windres" $ do
let cc = pgm_c dflags
cc_args = map Option (sOpt_c (settings dflags))
windres = pgm_windres dflags
opts = map Option (getOpts dflags opt_windres)
quote x = "\"" ++ x ++ "\""
args' =
Option ("--preprocessor=" ++
unwords (map quote (cc :
map showOpt opts ++
["-E", "-xc", "-DRC_INVOKED"])))
: Option "--use-temp-file"
: args
mb_env <- getGccEnv cc_args
runSomethingFiltered 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]
traceToolCommand :: DynFlags -> String -> IO a -> IO a
traceToolCommand dflags tool = withTiming
dflags (text $ "systool:" ++ tool) (const ())