module SysTools.Tasks where
import Exception
import ErrUtils
import HscTypes
import DynFlags
import Outputable
import GHC.Platform
import Util
import Data.List
import System.IO
import System.Process
import GhcPrelude
import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionMin, supportedLlvmVersionMax, llvmVersionStr, parseLlvmVersion)
import SysTools.Process
import 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
Exception.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 between "
++ llvmVersionStr supportedLlvmVersionMin
++ " and "
++ llvmVersionStr supportedLlvmVersionMax) ]
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 "Linker" 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
askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String
askAr dflags mb_cwd args = traceToolCommand dflags "ar" $ do
let ar = pgm_ar dflags
runSomethingWith dflags "Ar" ar args $ \real_args ->
readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }
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
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = traceToolCommand dflags "mkdll" $ do
let (p,args0) = pgm_dll dflags
args1 = args0 ++ args
mb_env <- getGccEnv (args0++args)
runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env
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 ())