module SysTools.Tasks where
import Exception
import ErrUtils
import DynFlags
import Outputable
import Platform
import Util
import Data.Char
import Data.List
import System.IO
import System.Process
import GhcPrelude
import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
import SysTools.Process
import SysTools.Info
runUnlit :: DynFlags -> [Option] -> IO ()
runUnlit dflags args = 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 = 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 = do
let prog = pgm_F dflags
opts = map Option (getOpts dflags opt_F)
runSomething dflags "Haskell pre-processor" prog (args ++ opts)
runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args = do
let (p,args0) = pgm_c dflags
args1 = map Option (getOpts dflags opt_c)
args2 = args0 ++ args1 ++ args
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
isContainedIn :: String -> String -> Bool
xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
askLd :: DynFlags -> [Option] -> IO String
askLd dflags args = 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 }
runSplit :: DynFlags -> [Option] -> IO ()
runSplit dflags args = do
let (p,args0) = pgm_s dflags
runSomething dflags "Splitter" p (args0++args)
runAs :: DynFlags -> [Option] -> IO ()
runAs dflags args = 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 = 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 = 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 = 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 (Int, Int))
figureLlvmVersion dflags = do
let (pgm,opts) = pgm_lc dflags
args = filter notNull (map showOpt opts)
args' = args ++ ["-version"]
ver <- catchIO (do
(pin, pout, perr, _) <- runInteractiveProcess pgm args'
Nothing Nothing
hSetBinaryMode pout False
_ <- hGetLine pout
vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
v <- case span (/= '.') vline of
("",_) -> fail "no digits!"
(x,y) -> return (read x
, read $ takeWhile isDigit $ drop 1 y)
hClose pin
hClose pout
hClose perr
return $ Just v
)
(\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)
return ver
runLink :: DynFlags -> [Option] -> IO ()
runLink dflags args = do
linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
let (p,args0) = pgm_l dflags
args1 = map Option (getOpts dflags opt_l)
args2 = args0 ++ linkargs ++ args1 ++ 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
runLibtool :: DynFlags -> [Option] -> IO ()
runLibtool dflags args = 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 = 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 = do
let ar = pgm_ar dflags
runSomethingWith dflags "Ar" ar args $ \real_args ->
readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }
runRanlib :: DynFlags -> [Option] -> IO ()
runRanlib dflags args = do
let ranlib = pgm_ranlib dflags
runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = 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 = do
let (gcc, gcc_args) = pgm_c dflags
windres = pgm_windres dflags
opts = map Option (getOpts dflags opt_windres)
quote x = "\"" ++ x ++ "\""
args' =
Option ("--preprocessor=" ++
unwords (map quote (gcc :
map showOpt gcc_args ++
map showOpt opts ++
["-E", "-xc", "-DRC_INVOKED"])))
: Option "--use-temp-file"
: args
mb_env <- getGccEnv gcc_args
runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env
touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg =
runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]