{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
--
-- Tasks running external programs for SysTools
--
-- (c) The GHC Team 2017
--
-----------------------------------------------------------------------------
module GHC.SysTools.Tasks where

import GHC.Prelude
import GHC.Platform
import GHC.ForeignSrcLang

import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion)

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 Data.List (tails, isPrefixOf)
import System.IO
import System.Process

{-
************************************************************************
*                                                                      *
\subsection{Running an external program}
*                                                                      *
************************************************************************
-}

runUnlit :: Logger -> DynFlags -> [Option] -> IO ()
runUnlit :: Logger -> DynFlags -> [Option] -> IO ()
runUnlit Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"unlit" forall a b. (a -> b) -> a -> b
$ do
  let prog :: String
prog = DynFlags -> String
pgm_L DynFlags
dflags
      opts :: [String]
opts = forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_L
  Logger -> DynFlags -> String -> String -> [Option] -> IO ()
runSomething Logger
logger DynFlags
dflags String
"Literate pre-processor" String
prog
               (forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
opts forall a. [a] -> [a] -> [a]
++ [Option]
args)

runCpp :: Logger -> DynFlags -> [Option] -> IO ()
runCpp :: Logger -> DynFlags -> [Option] -> IO ()
runCpp Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"cpp" forall a b. (a -> b) -> a -> b
$ do
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_P DynFlags
dflags
      args1 :: [Option]
args1 = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_P)
      args2 :: [Option]
args2 = [String -> Option
Option String
"-Werror" | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WarnIsError DynFlags
dflags]
                forall a. [a] -> [a] -> [a]
++ [String -> Option
Option String
"-Wundef" | WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnCPPUndef DynFlags
dflags]
  Maybe [(String, String)]
mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  Logger
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger DynFlags
dflags forall a. a -> a
id  String
"C pre-processor" String
p
                       ([Option]
args0 forall a. [a] -> [a] -> [a]
++ [Option]
args1 forall a. [a] -> [a] -> [a]
++ [Option]
args2 forall a. [a] -> [a] -> [a]
++ [Option]
args) forall a. Maybe a
Nothing Maybe [(String, String)]
mb_env

runPp :: Logger -> DynFlags -> [Option] -> IO ()
runPp :: Logger -> DynFlags -> [Option] -> IO ()
runPp Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"pp" forall a b. (a -> b) -> a -> b
$ do
  let prog :: String
prog = DynFlags -> String
pgm_F DynFlags
dflags
      opts :: [Option]
opts = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_F)
  Logger -> DynFlags -> String -> String -> [Option] -> IO ()
runSomething Logger
logger DynFlags
dflags String
"Haskell pre-processor" String
prog ([Option]
args forall a. [a] -> [a] -> [a]
++ [Option]
opts)

-- | Run compiler of C-like languages and raw objects (such as gcc or clang).
runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runCc :: Maybe ForeignSrcLang
-> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runCc Maybe ForeignSrcLang
mLanguage Logger
logger TmpFs
tmpfs DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"cc" forall a b. (a -> b) -> a -> b
$ do
  let p :: String
p = DynFlags -> String
pgm_c DynFlags
dflags
      args1 :: [Option]
args1 = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
userOpts
      args2 :: [Option]
args2 = [Option]
languageOptions forall a. [a] -> [a] -> [a]
++ [Option]
args forall a. [a] -> [a] -> [a]
++ [Option]
args1
      -- We take care to pass -optc flags in args1 last to ensure that the
      -- user can override flags passed by GHC. See #14452.
  Maybe [(String, String)]
mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  Logger
-> TmpFs
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe [(String, String)]
-> IO ()
runSomethingResponseFile Logger
logger TmpFs
tmpfs DynFlags
dflags String -> String
cc_filter String
"C Compiler" String
p [Option]
args2 Maybe [(String, String)]
mb_env
 where
  -- discard some harmless warnings from gcc that we can't turn off
  cc_filter :: String -> String
cc_filter = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
doFilter forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

  {-
  gcc gives warnings in chunks like so:
      In file included from /foo/bar/baz.h:11,
                       from /foo/bar/baz2.h:22,
                       from wibble.c:33:
      /foo/flibble:14: global register variable ...
      /foo/flibble:15: warning: call-clobbered r...
  We break it up into its chunks, remove any call-clobbered register
  warnings from each chunk, and then delete any chunks that we have
  emptied of warnings.
  -}
  doFilter :: [String] -> [String]
doFilter = [([String], [String])] -> [String]
unChunkWarnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([String], [String])] -> [([String], [String])]
filterWarnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String] -> [([String], [String])]
chunkWarnings []
  -- We can't assume that the output will start with an "In file inc..."
  -- line, so we start off expecting a list of warnings rather than a
  -- location stack.
  chunkWarnings :: [String] -- The location stack to use for the next
                            -- list of warnings
                -> [String] -- The remaining lines to look at
                -> [([String], [String])]
  chunkWarnings :: [String] -> [String] -> [([String], [String])]
chunkWarnings [String]
loc_stack [] = [([String]
loc_stack, [])]
  chunkWarnings [String]
loc_stack [String]
xs
      = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break String -> Bool
loc_stack_start [String]
xs of
        ([String]
warnings, String
lss:[String]
xs') ->
            case forall a. (a -> Bool) -> [a] -> ([a], [a])
span String -> Bool
loc_start_continuation [String]
xs' of
            ([String]
lsc, [String]
xs'') ->
                ([String]
loc_stack, [String]
warnings) forall a. a -> [a] -> [a]
: [String] -> [String] -> [([String], [String])]
chunkWarnings (String
lss forall a. a -> [a] -> [a]
: [String]
lsc) [String]
xs''
        ([String], [String])
_ -> [([String]
loc_stack, [String]
xs)]

  filterWarnings :: [([String], [String])] -> [([String], [String])]
  filterWarnings :: [([String], [String])] -> [([String], [String])]
filterWarnings [] = []
  -- If the warnings are already empty then we are probably doing
  -- something wrong, so don't delete anything
  filterWarnings (([String]
xs, []) : [([String], [String])]
zs) = ([String]
xs, []) forall a. a -> [a] -> [a]
: [([String], [String])] -> [([String], [String])]
filterWarnings [([String], [String])]
zs
  filterWarnings (([String]
xs, [String]
ys) : [([String], [String])]
zs) = case forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
wantedWarning [String]
ys of
                                       [] -> [([String], [String])] -> [([String], [String])]
filterWarnings [([String], [String])]
zs
                                       [String]
ys' -> ([String]
xs, [String]
ys') forall a. a -> [a] -> [a]
: [([String], [String])] -> [([String], [String])]
filterWarnings [([String], [String])]
zs

  unChunkWarnings :: [([String], [String])] -> [String]
  unChunkWarnings :: [([String], [String])] -> [String]
unChunkWarnings [] = []
  unChunkWarnings (([String]
xs, [String]
ys) : [([String], [String])]
zs) = [String]
xs forall a. [a] -> [a] -> [a]
++ [String]
ys forall a. [a] -> [a] -> [a]
++ [([String], [String])] -> [String]
unChunkWarnings [([String], [String])]
zs

  loc_stack_start :: String -> Bool
loc_stack_start        String
s = String
"In file included from " forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
  loc_start_continuation :: String -> Bool
loc_start_continuation String
s = String
"                 from " forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
  wantedWarning :: String -> Bool
wantedWarning String
w
   | String
"warning: call-clobbered register used" String -> String -> Bool
`isContainedIn` String
w = Bool
False
   | Bool
otherwise = Bool
True

  -- force the C compiler to interpret this file as C when
  -- compiling .hc files, by adding the -x c option.
  -- Also useful for plain .c files, just in case GHC saw a
  -- -x c option.
  ([Option]
languageOptions, [String]
userOpts) = case Maybe ForeignSrcLang
mLanguage of
    Maybe ForeignSrcLang
Nothing -> ([], [String]
userOpts_c)
    Just ForeignSrcLang
language -> ([String -> Option
Option String
"-x", String -> Option
Option String
languageName], [String]
opts)
      where
        (String
languageName, [String]
opts) = case ForeignSrcLang
language of
          ForeignSrcLang
LangC      -> (String
"c",             [String]
userOpts_c)
          ForeignSrcLang
LangCxx    -> (String
"c++",           [String]
userOpts_cxx)
          ForeignSrcLang
LangObjc   -> (String
"objective-c",   [String]
userOpts_c)
          ForeignSrcLang
LangObjcxx -> (String
"objective-c++", [String]
userOpts_cxx)
          ForeignSrcLang
LangAsm    -> (String
"assembler",     [])
          ForeignSrcLang
RawObject  -> (String
"c",             []) -- claim C for lack of a better idea
  userOpts_c :: [String]
userOpts_c   = forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_c
  userOpts_cxx :: [String]
userOpts_cxx = forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_cxx

isContainedIn :: String -> String -> Bool
String
xs isContainedIn :: String -> String -> Bool
`isContainedIn` String
ys = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
xs forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (forall a. [a] -> [[a]]
tails String
ys)

-- | Run the linker with some arguments and return the output
askLd :: Logger -> DynFlags -> [Option] -> IO String
askLd :: Logger -> DynFlags -> [Option] -> IO String
askLd Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"linker" forall a b. (a -> b) -> a -> b
$ do
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_l DynFlags
dflags
      args1 :: [Option]
args1     = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_l)
      args2 :: [Option]
args2     = [Option]
args0 forall a. [a] -> [a] -> [a]
++ [Option]
args1 forall a. [a] -> [a] -> [a]
++ [Option]
args
  Maybe [(String, String)]
mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  forall a.
Logger
-> DynFlags
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger DynFlags
dflags String
"gcc" String
p [Option]
args2 forall a b. (a -> b) -> a -> b
$ \[String]
real_args ->
    CreateProcess -> IO (ExitCode, String)
readCreateProcessWithExitCode' (String -> [String] -> CreateProcess
proc String
p [String]
real_args){ env :: Maybe [(String, String)]
env = Maybe [(String, String)]
mb_env }

runAs :: Logger -> DynFlags -> [Option] -> IO ()
runAs :: Logger -> DynFlags -> [Option] -> IO ()
runAs Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"as" forall a b. (a -> b) -> a -> b
$ do
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_a DynFlags
dflags
      args1 :: [Option]
args1 = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_a)
      args2 :: [Option]
args2 = [Option]
args0 forall a. [a] -> [a] -> [a]
++ [Option]
args1 forall a. [a] -> [a] -> [a]
++ [Option]
args
  Maybe [(String, String)]
mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  Logger
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger DynFlags
dflags forall a. a -> a
id String
"Assembler" String
p [Option]
args2 forall a. Maybe a
Nothing Maybe [(String, String)]
mb_env

-- | Run the LLVM Optimiser
runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()
runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()
runLlvmOpt Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"opt" forall a b. (a -> b) -> a -> b
$ do
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_lo DynFlags
dflags
      args1 :: [Option]
args1 = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
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.
  Logger -> DynFlags -> String -> String -> [Option] -> IO ()
runSomething Logger
logger DynFlags
dflags String
"LLVM Optimiser" String
p ([Option]
args1 forall a. [a] -> [a] -> [a]
++ [Option]
args forall a. [a] -> [a] -> [a]
++ [Option]
args0)

-- | Run the LLVM Compiler
runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()
runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()
runLlvmLlc Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"llc" forall a b. (a -> b) -> a -> b
$ do
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_lc DynFlags
dflags
      args1 :: [Option]
args1 = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_lc)
  Logger -> DynFlags -> String -> String -> [Option] -> IO ()
runSomething Logger
logger DynFlags
dflags String
"LLVM Compiler" String
p ([Option]
args0 forall a. [a] -> [a] -> [a]
++ [Option]
args1 forall a. [a] -> [a] -> [a]
++ [Option]
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 :: Logger -> DynFlags -> [Option] -> IO ()
runClang :: Logger -> DynFlags -> [Option] -> IO ()
runClang Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"clang" forall a b. (a -> b) -> a -> b
$ do
  let (String
clang,[Option]
_) = DynFlags -> (String, [Option])
pgm_lcc DynFlags
dflags
      -- be careful what options we call clang with
      -- see #5903 and #7617 for bugs caused by this.
      (String
_,[Option]
args0) = DynFlags -> (String, [Option])
pgm_a DynFlags
dflags
      args1 :: [Option]
args1 = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_a)
      args2 :: [Option]
args2 = [Option]
args0 forall a. [a] -> [a] -> [a]
++ [Option]
args1 forall a. [a] -> [a] -> [a]
++ [Option]
args
  Maybe [(String, String)]
mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
    (Logger
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger DynFlags
dflags forall a. a -> a
id String
"Clang (Assembler)" String
clang [Option]
args2 forall a. Maybe a
Nothing Maybe [(String, String)]
mb_env)
    (\(SomeException
err :: SomeException) -> do
        Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$
            String -> SDoc
text (String
"Error running clang! you need clang installed to use the" forall a. [a] -> [a] -> [a]
++
                  String
" LLVM backend") SDoc -> SDoc -> SDoc
$+$
            String -> SDoc
text String
"(or GHC tried to execute clang incorrectly)"
        forall e a. Exception e => e -> IO a
throwIO SomeException
err
    )

-- | Figure out which version of LLVM we are running this session
figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion Logger
logger DynFlags
dflags = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"llc" forall a b. (a -> b) -> a -> b
$ do
  let (String
pgm,[Option]
opts) = DynFlags -> (String, [Option])
pgm_lc DynFlags
dflags
      args :: [String]
args = forall a. (a -> Bool) -> [a] -> [a]
filter forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull (forall a b. (a -> b) -> [a] -> [b]
map Option -> String
showOpt [Option]
opts)
      -- we grab the args even though they should be useless just in
      -- case the user is using a customised 'llc' that requires some
      -- of the options they've specified. llc doesn't care what other
      -- options are specified when '-version' is used.
      args' :: [String]
args' = [String]
args forall a. [a] -> [a] -> [a]
++ [String
"-version"]
  forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (do
              (Handle
pin, Handle
pout, Handle
perr, ProcessHandle
p) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
pgm [String]
args'
                                              forall a. Maybe a
Nothing forall a. Maybe a
Nothing
              {- > llc -version
                  LLVM (http://llvm.org/):
                    LLVM version 3.5.2
                    ...
              -}
              Handle -> Bool -> IO ()
hSetBinaryMode Handle
pout Bool
False
              String
_     <- Handle -> IO String
hGetLine Handle
pout
              String
vline <- Handle -> IO String
hGetLine Handle
pout
              let mb_ver :: Maybe LlvmVersion
mb_ver = String -> Maybe LlvmVersion
parseLlvmVersion String
vline
              Handle -> IO ()
hClose Handle
pin
              Handle -> IO ()
hClose Handle
pout
              Handle -> IO ()
hClose Handle
perr
              ExitCode
_ <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p
              forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LlvmVersion
mb_ver
            )
            (\IOException
err -> do
                Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2
                    (String -> SDoc
text String
"Error (figuring out LLVM version):" SDoc -> SDoc -> SDoc
<+>
                      String -> SDoc
text (forall a. Show a => a -> String
show IOException
err))
                Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
                    [ String -> SDoc
text String
"Warning:", Int -> SDoc -> SDoc
nest Int
9 forall a b. (a -> b) -> a -> b
$
                          String -> SDoc
text String
"Couldn't figure out LLVM version!" SDoc -> SDoc -> SDoc
$$
                          String -> SDoc
text (String
"Make sure you have installed LLVM between ["
                                forall a. [a] -> [a] -> [a]
++ LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersionLowerBound
                                forall a. [a] -> [a] -> [a]
++ String
" and "
                                forall a. [a] -> [a] -> [a]
++ LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersionUpperBound
                                forall a. [a] -> [a] -> [a]
++ String
")") ]
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)



runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runLink Logger
logger TmpFs
tmpfs DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"linker" forall a b. (a -> b) -> a -> b
$ 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`.
  [Option]
linkargs <- LinkerInfo -> [Option]
neededLinkArgs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Logger -> DynFlags -> IO LinkerInfo
getLinkerInfo Logger
logger DynFlags
dflags
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_l DynFlags
dflags
      optl_args :: [Option]
optl_args = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_l)
      args2 :: [Option]
args2     = [Option]
args0 forall a. [a] -> [a] -> [a]
++ [Option]
linkargs forall a. [a] -> [a] -> [a]
++ [Option]
args forall a. [a] -> [a] -> [a]
++ [Option]
optl_args
  Maybe [(String, String)]
mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  Logger
-> TmpFs
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe [(String, String)]
-> IO ()
runSomethingResponseFile Logger
logger TmpFs
tmpfs DynFlags
dflags String -> String
ld_filter String
"Linker" String
p [Option]
args2 Maybe [(String, String)]
mb_env
  where
    ld_filter :: String -> String
ld_filter = case (Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)) of
                  OS
OSSolaris2 -> String -> String
sunos_ld_filter
                  OS
_ -> forall a. a -> a
id
{-
  SunOS/Solaris ld emits harmless warning messages about unresolved
  symbols in case of compiling into shared library when we do not
  link against all the required libs. That is the case of GHC which
  does not link against RTS library explicitly in order to be able to
  choose the library later based on binary application linking
  parameters. The warnings look like:

Undefined                       first referenced
  symbol                             in file
stg_ap_n_fast                       ./T2386_Lib.o
stg_upd_frame_info                  ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
newCAF                              ./T2386_Lib.o
stg_bh_upd_frame_info               ./T2386_Lib.o
stg_ap_ppp_fast                     ./T2386_Lib.o
templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
stg_ap_p_fast                       ./T2386_Lib.o
stg_ap_pp_fast                      ./T2386_Lib.o
ld: warning: symbol referencing errors

  this is actually coming from T2386 testcase. The emitting of those
  warnings is also a reason why so many TH testcases fail on Solaris.

  Following filter code is SunOS/Solaris linker specific and should
  filter out only linker warnings. Please note that the logic is a
  little bit more complex due to the simple reason that we need to preserve
  any other linker emitted messages. If there are any. Simply speaking
  if we see "Undefined" and later "ld: warning:..." then we omit all
  text between (including) the marks. Otherwise we copy the whole output.
-}
    sunos_ld_filter :: String -> String
    sunos_ld_filter :: String -> String
sunos_ld_filter = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
sunos_ld_filter' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    sunos_ld_filter' :: [String] -> [String]
sunos_ld_filter' [String]
x = if ([String] -> Bool
undefined_found [String]
x Bool -> Bool -> Bool
&& [String] -> Bool
ld_warning_found [String]
x)
                          then ([String] -> [String]
ld_prefix [String]
x) forall a. [a] -> [a] -> [a]
++ ([String] -> [String]
ld_postfix [String]
x)
                          else [String]
x
    breakStartsWith :: [a] -> [[a]] -> ([[a]], [[a]])
breakStartsWith [a]
x [[a]]
y = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
x) [[a]]
y
    ld_prefix :: [String] -> [String]
ld_prefix = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Eq a => [a] -> [[a]] -> ([[a]], [[a]])
breakStartsWith String
"Undefined"
    undefined_found :: [String] -> Bool
undefined_found = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Eq a => [a] -> [[a]] -> ([[a]], [[a]])
breakStartsWith String
"Undefined"
    ld_warn_break :: [String] -> ([String], [String])
ld_warn_break = forall {a}. Eq a => [a] -> [[a]] -> ([[a]], [[a]])
breakStartsWith String
"ld: warning: symbol referencing errors"
    ld_postfix :: [String] -> [String]
ld_postfix = forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ([String], [String])
ld_warn_break
    ld_warning_found :: [String] -> Bool
ld_warning_found = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ([String], [String])
ld_warn_break

-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
#if defined(mingw32_HOST_OS)
runMergeObjects logger tmpfs  dflags args =
#else
runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runMergeObjects Logger
logger TmpFs
_tmpfs DynFlags
dflags [Option]
args =
#endif
  forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"merge-objects" forall a b. (a -> b) -> a -> b
$ do
    let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_lm DynFlags
dflags
        optl_args :: [Option]
optl_args = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_lm)
        args2 :: [Option]
args2     = [Option]
args0 forall a. [a] -> [a] -> [a]
++ [Option]
args forall a. [a] -> [a] -> [a]
++ [Option]
optl_args
    -- N.B. Darwin's ld64 doesn't support response files. Consequently we only
    -- use them on Windows where they are truly necessary.
#if defined(mingw32_HOST_OS)
    mb_env <- getGccEnv args2
    runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env
#else
    Logger -> DynFlags -> String -> String -> [Option] -> IO ()
runSomething Logger
logger DynFlags
dflags String
"Merge objects" String
p [Option]
args2
#endif

runLibtool :: Logger -> DynFlags -> [Option] -> IO ()
runLibtool :: Logger -> DynFlags -> [Option] -> IO ()
runLibtool Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"libtool" forall a b. (a -> b) -> a -> b
$ do
  [Option]
linkargs <- LinkerInfo -> [Option]
neededLinkArgs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Logger -> DynFlags -> IO LinkerInfo
getLinkerInfo Logger
logger DynFlags
dflags
  let args1 :: [Option]
args1      = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_l)
      args2 :: [Option]
args2      = [String -> Option
Option String
"-static"] forall a. [a] -> [a] -> [a]
++ [Option]
args1 forall a. [a] -> [a] -> [a]
++ [Option]
args forall a. [a] -> [a] -> [a]
++ [Option]
linkargs
      libtool :: String
libtool    = DynFlags -> String
pgm_libtool DynFlags
dflags
  Maybe [(String, String)]
mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  Logger
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger DynFlags
dflags forall a. a -> a
id String
"Libtool" String
libtool [Option]
args2 forall a. Maybe a
Nothing Maybe [(String, String)]
mb_env

runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()
runAr :: Logger -> DynFlags -> Maybe String -> [Option] -> IO ()
runAr Logger
logger DynFlags
dflags Maybe String
cwd [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"ar" forall a b. (a -> b) -> a -> b
$ do
  let ar :: String
ar = DynFlags -> String
pgm_ar DynFlags
dflags
  Logger
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger DynFlags
dflags forall a. a -> a
id String
"Ar" String
ar [Option]
args Maybe String
cwd forall a. Maybe a
Nothing

askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String
askOtool :: Logger -> DynFlags -> Maybe String -> [Option] -> IO String
askOtool Logger
logger DynFlags
dflags Maybe String
mb_cwd [Option]
args = do
  let otool :: String
otool = DynFlags -> String
pgm_otool DynFlags
dflags
  forall a.
Logger
-> DynFlags
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger DynFlags
dflags String
"otool" String
otool [Option]
args forall a b. (a -> b) -> a -> b
$ \[String]
real_args ->
    CreateProcess -> IO (ExitCode, String)
readCreateProcessWithExitCode' (String -> [String] -> CreateProcess
proc String
otool [String]
real_args){ cwd :: Maybe String
cwd = Maybe String
mb_cwd }

runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()
runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()
runInstallNameTool Logger
logger DynFlags
dflags [Option]
args = do
  let tool :: String
tool = DynFlags -> String
pgm_install_name_tool DynFlags
dflags
  Logger
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger DynFlags
dflags forall a. a -> a
id String
"Install Name Tool" String
tool [Option]
args forall a. Maybe a
Nothing forall a. Maybe a
Nothing

runRanlib :: Logger -> DynFlags -> [Option] -> IO ()
runRanlib :: Logger -> DynFlags -> [Option] -> IO ()
runRanlib Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"ranlib" forall a b. (a -> b) -> a -> b
$ do
  let ranlib :: String
ranlib = DynFlags -> String
pgm_ranlib DynFlags
dflags
  Logger
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger DynFlags
dflags forall a. a -> a
id String
"Ranlib" String
ranlib [Option]
args forall a. Maybe a
Nothing forall a. Maybe a
Nothing

runWindres :: Logger -> DynFlags -> [Option] -> IO ()
runWindres :: Logger -> DynFlags -> [Option] -> IO ()
runWindres Logger
logger DynFlags
dflags [Option]
args = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"windres" forall a b. (a -> b) -> a -> b
$ do
  let cc :: String
cc = DynFlags -> String
pgm_c DynFlags
dflags
      cc_args :: [Option]
cc_args = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (Settings -> [String]
sOpt_c (DynFlags -> Settings
settings DynFlags
dflags))
      windres :: String
windres = DynFlags -> String
pgm_windres DynFlags
dflags
      opts :: [Option]
opts = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_windres)
      quote :: String -> String
quote String
x = String
"\"" forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
"\""
      args' :: [Option]
args' = -- If windres.exe and gcc.exe are in a directory containing
              -- spaces then windres fails to run gcc. We therefore need
              -- to tell it what command to use...
              String -> Option
Option (String
"--preprocessor=" forall a. [a] -> [a] -> [a]
++
                      [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map String -> String
quote (String
cc forall a. a -> [a] -> [a]
:
                                          forall a b. (a -> b) -> [a] -> [b]
map Option -> String
showOpt [Option]
opts forall a. [a] -> [a] -> [a]
++
                                          [String
"-E", String
"-xc", String
"-DRC_INVOKED"])))
              -- ...but if we do that then if windres calls popen then
              -- it can't understand the quoting, so we have to use
              -- --use-temp-file so that it interprets it correctly.
              -- See #1828.
            forall a. a -> [a] -> [a]
: String -> Option
Option String
"--use-temp-file"
            forall a. a -> [a] -> [a]
: [Option]
args
  Maybe [(String, String)]
mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
cc_args
  Logger
-> DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger DynFlags
dflags forall a. a -> a
id String
"Windres" String
windres [Option]
args' forall a. Maybe a
Nothing Maybe [(String, String)]
mb_env

touch :: Logger -> DynFlags -> String -> String -> IO ()
touch :: Logger -> DynFlags -> String -> String -> IO ()
touch Logger
logger DynFlags
dflags String
purpose String
arg = forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
"touch" forall a b. (a -> b) -> a -> b
$
  Logger -> DynFlags -> String -> String -> [Option] -> IO ()
runSomething Logger
logger DynFlags
dflags String
purpose (DynFlags -> String
pgm_T DynFlags
dflags) [String -> String -> Option
FileOption String
"" String
arg]

-- * Tracing utility

-- | Record in the eventlog when the given tool command starts
--   and finishes, prepending the given 'String' with
--   \"systool:\", to easily be able to collect and process
--   all the systool events.
--
--   For those events to show up in the eventlog, you need
--   to run GHC with @-v2@ or @-ddump-timings@.
traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand :: forall a. Logger -> DynFlags -> String -> IO a -> IO a
traceToolCommand Logger
logger DynFlags
dflags String
tool = forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
  DynFlags
dflags (String -> SDoc
text forall a b. (a -> b) -> a -> b
$ String
"systool:" forall a. [a] -> [a] -> [a]
++ String
tool) (forall a b. a -> b -> a
const ())