{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
--
-- Tasks running external programs for SysTools
--
-- (c) The GHC Team 2017
--
-----------------------------------------------------------------------------
module GHC.SysTools.Tasks where

import GHC.Prelude
import GHC.ForeignSrcLang

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

import GHC.Settings

import GHC.SysTools.Process

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.Panic

import Control.Monad
import Data.List (tails, isPrefixOf)
import Data.Maybe (fromMaybe)
import System.IO
import System.Process
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Errors
import GHC.Driver.Errors.Types (GhcMessage(..), DriverMessage (DriverNoConfiguredLLVMToolchain))
import GHC.Driver.CmdLine (warnsToMessages)
import GHC.Types.SrcLoc (noLoc)

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

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

-- | Prepend the working directory to the search path.
-- Note [Filepaths and Multiple Home Units]
augmentImports :: DynFlags  -> [FilePath] -> [FilePath]
augmentImports :: DynFlags -> [String] -> [String]
augmentImports DynFlags
dflags [String]
fps | Maybe String
Nothing <- DynFlags -> Maybe String
workingDirectory DynFlags
dflags  = [String]
fps
augmentImports DynFlags
_ [] = []
augmentImports DynFlags
_ [String
x] = [String
x]
augmentImports DynFlags
dflags (String
"-include":String
fp:[String]
fps) = String
"-include" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: DynFlags -> String -> String
augmentByWorkingDirectory DynFlags
dflags String
fp  String -> [String] -> [String]
forall a. a -> [a] -> [a]
: DynFlags -> [String] -> [String]
augmentImports DynFlags
dflags [String]
fps
augmentImports DynFlags
dflags (String
fp1: String
fp2: [String]
fps) = String
fp1 String -> [String] -> [String]
forall a. a -> [a] -> [a]
: DynFlags -> [String] -> [String]
augmentImports DynFlags
dflags (String
fp2String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fps)

-- | Discard some harmless warnings from gcc that we can't turn off
cc_filter :: String -> String
cc_filter :: String -> String
cc_filter = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
doFilter ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines where
  {-
  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 ([([String], [String])] -> [String])
-> ([String] -> [([String], [String])]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([String], [String])] -> [([String], [String])]
filterWarnings ([([String], [String])] -> [([String], [String])])
-> ([String] -> [([String], [String])])
-> [String]
-> [([String], [String])]
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 (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break String -> Bool
loc_stack_start [String]
xs of
        ([String]
warnings, String
lss:[String]
xs') ->
            case (String -> Bool) -> [String] -> ([String], [String])
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) ([String], [String])
-> [([String], [String])] -> [([String], [String])]
forall a. a -> [a] -> [a]
: [String] -> [String] -> [([String], [String])]
chunkWarnings (String
lss String -> [String] -> [String]
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, []) ([String], [String])
-> [([String], [String])] -> [([String], [String])]
forall a. a -> [a] -> [a]
: [([String], [String])] -> [([String], [String])]
filterWarnings [([String], [String])]
zs
  filterWarnings (([String]
xs, [String]
ys) : [([String], [String])]
zs) = case (String -> Bool) -> [String] -> [String]
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') ([String], [String])
-> [([String], [String])] -> [([String], [String])]
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ys [String] -> [String] -> [String]
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 " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
  loc_start_continuation :: String -> Bool
loc_start_continuation String
s = String
"                 from " String -> String -> Bool
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

-- | See the Note [Preprocessing invocations]
data SourceCodePreprocessor
  = SCPCpp
    -- ^ Use the ordinary C preprocessor
  | SCPHsCpp
    -- ^ Use the Haskell C preprocessor (don't remove C comments, don't break on names including single quotes)
  | SCPJsCpp
    -- ^ Use the JavaScript preprocessor (don't remove jsdoc and multiline comments)
  | SCPCmmCpp
    -- ^ Use the C-- preprocessor (don't emit debug information)
  deriving (SourceCodePreprocessor -> SourceCodePreprocessor -> Bool
(SourceCodePreprocessor -> SourceCodePreprocessor -> Bool)
-> (SourceCodePreprocessor -> SourceCodePreprocessor -> Bool)
-> Eq SourceCodePreprocessor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SourceCodePreprocessor -> SourceCodePreprocessor -> Bool
== :: SourceCodePreprocessor -> SourceCodePreprocessor -> Bool
$c/= :: SourceCodePreprocessor -> SourceCodePreprocessor -> Bool
/= :: SourceCodePreprocessor -> SourceCodePreprocessor -> Bool
Eq)

-- | Run source code preprocessor.
-- See also Note [Preprocessing invocations] in GHC.SysTools.Cpp
runSourceCodePreprocessor
  :: Logger
  -> TmpFs
  -> DynFlags
  -> SourceCodePreprocessor
  -> [Option]
  -> IO ()
runSourceCodePreprocessor :: Logger
-> TmpFs -> DynFlags -> SourceCodePreprocessor -> [Option] -> IO ()
runSourceCodePreprocessor Logger
logger TmpFs
tmpfs DynFlags
dflags SourceCodePreprocessor
preprocessor [Option]
args =
  Logger -> String -> IO () -> IO ()
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
logger_name (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let
      (String
program, [Option]
configured_args) = DynFlags -> (String, [Option])
pgm_getter DynFlags
dflags
      runtime_args :: [Option]
runtime_args = String -> Option
Option (String -> Option) -> [String] -> [Option]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DynFlags -> [String] -> [String]
augmentImports DynFlags
dflags ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_getter)
      extra_warns :: [Option]
extra_warns = [String -> Option
Option String
"-Werror" | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WarnIsError DynFlags
dflags]
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [String -> Option
Option String
"-Wundef" | WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnCPPUndef DynFlags
dflags]
      all_args :: [Option]
all_args = [Option]
configured_args [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
runtime_args [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
extra_warns [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args

    mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv ([Option]
configured_args [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
runtime_args)

    runSomething readable_name program all_args mb_env

  where
    toolSettings' :: ToolSettings
toolSettings' = DynFlags -> ToolSettings
toolSettings DynFlags
dflags
    cmmG0 :: [String]
cmmG0 = [String
"-g0" | ToolSettings -> Bool
toolSettings_cmmCppSupportsG0 ToolSettings
toolSettings']
    -- GCC <=10 (pre commit r11-5596-g934a54180541d2) implied -dD for debug
    -- flags by the spec snippet %{g3|ggdb3|gstabs3|gxcoff3|gvms3:-dD}.  This
    -- means that a g0 will not override a previously-specified -g3 causing
    -- debug info emission (see https://gcc.gnu.org/PR97989).  We're filtering
    -- -optc here, rather than the combined command line, in order to avoid an
    -- issue where a user has to, for some reason, override our decision.  If
    -- they see the need to do that, they can pass -optCmmP.
    g3Flags :: [String]
g3Flags = [String
"-g3", String
"-ggdb3", String
"-gstabs3", String
"-gxcoff3", String
"-gvms3"]
    optCFiltered :: DynFlags -> [String]
optCFiltered = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
g3Flags) ([String] -> [String])
-> (DynFlags -> [String]) -> DynFlags -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> [String]
opt_c
    -- In the wild (and GHC), there is lots of code assuming that -optc gets
    -- passed to the C-- preprocessor too.  Note that the arguments are
    -- reversed by getOpts. That is, in the invocation, first come the runtime
    -- C opts, then -g0, then the runtime CmmP opts.
    cAndCmmOpt :: DynFlags -> [String]
cAndCmmOpt DynFlags
dflags =  DynFlags -> [String]
opt_CmmP DynFlags
dflags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
cmmG0 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [String]
optCFiltered DynFlags
dflags
    (String
logger_name, DynFlags -> (String, [Option])
pgm_getter, DynFlags -> [String]
opt_getter, String
readable_name)
      = case SourceCodePreprocessor
preprocessor of
        SourceCodePreprocessor
SCPCpp -> (String
"cpp", DynFlags -> (String, [Option])
pgm_cpp, DynFlags -> [String]
opt_c, String
"C pre-processor")
        SourceCodePreprocessor
SCPHsCpp -> (String
"hs-cpp", DynFlags -> (String, [Option])
pgm_P, DynFlags -> [String]
opt_P, String
"Haskell C pre-processor")
        SourceCodePreprocessor
SCPJsCpp -> (String
"js-cpp", DynFlags -> (String, [Option])
pgm_JSP, DynFlags -> [String]
opt_JSP, String
"JavaScript C pre-processor")
        SourceCodePreprocessor
SCPCmmCpp -> (String
"cmm-cpp", DynFlags -> (String, [Option])
pgm_CmmP, DynFlags -> [String]
cAndCmmOpt, String
"C-- C pre-processor")

    runSomethingResponseFileCpp :: String -> String -> [Option] -> Maybe [(String, String)] -> IO ()
runSomethingResponseFileCpp
      = Logger
-> TmpFs
-> TempDir
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe [(String, String)]
-> IO ()
runSomethingResponseFile Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) String -> String
cc_filter
    runSomethingFilteredOther :: String -> String -> [Option] -> Maybe [(String, String)] -> IO ()
runSomethingFilteredOther String
phase_name String
pgm [Option]
args Maybe [(String, String)]
mb_env
      = Logger
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger String -> String
forall a. a -> a
id String
phase_name String
pgm [Option]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
mb_env

    runSomething :: String -> String -> [Option] -> Maybe [(String, String)] -> IO ()
runSomething
      = case SourceCodePreprocessor
preprocessor of
        SourceCodePreprocessor
SCPCpp -> String -> String -> [Option] -> Maybe [(String, String)] -> IO ()
runSomethingResponseFileCpp
        SourceCodePreprocessor
SCPHsCpp -> String -> String -> [Option] -> Maybe [(String, String)] -> IO ()
runSomethingFilteredOther
        SourceCodePreprocessor
SCPJsCpp -> String -> String -> [Option] -> Maybe [(String, String)] -> IO ()
runSomethingFilteredOther
        SourceCodePreprocessor
SCPCmmCpp -> String -> String -> [Option] -> Maybe [(String, String)] -> IO ()
runSomethingResponseFileCpp

runPp :: Logger -> DynFlags -> [Option] -> IO ()
runPp :: Logger -> DynFlags -> [Option] -> IO ()
runPp Logger
logger DynFlags
dflags [Option]
args = Logger -> String -> IO () -> IO ()
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
"pp" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let prog :: String
prog = DynFlags -> String
pgm_F DynFlags
dflags
      opts :: [Option]
opts = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_F)
  Logger -> String -> String -> [Option] -> IO ()
runSomething Logger
logger String
"Haskell pre-processor" String
prog ([Option]
args [Option] -> [Option] -> [Option]
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 = Logger -> String -> IO () -> IO ()
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
"cc" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let args1 :: [Option]
args1 = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option [String]
userOpts
      args2 :: [Option]
args2 = [Option]
languageOptions [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args [Option] -> [Option] -> [Option]
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.
  mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter dbgstring prog args2
                           mb_env
 where
  -- 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, String
prog, String
dbgstring) = case Maybe ForeignSrcLang
mLanguage of
    Maybe ForeignSrcLang
Nothing -> ([], [String]
userOpts_c, DynFlags -> String
pgm_c DynFlags
dflags, String
"C Compiler")
    Just ForeignSrcLang
language -> ([String -> Option
Option String
"-x", String -> Option
Option String
languageName], [String]
opts, String
prog, String
dbgstr)
      where
        (String
languageName, [String]
opts, String
prog, String
dbgstr) = case ForeignSrcLang
language of
          ForeignSrcLang
LangC      -> (String
"c",             [String]
userOpts_c
                        ,DynFlags -> String
pgm_c DynFlags
dflags,    String
"C Compiler")
          ForeignSrcLang
LangCxx    -> (String
"c++",           [String]
userOpts_cxx
                        ,DynFlags -> String
pgm_cxx DynFlags
dflags , String
"C++ Compiler")
          ForeignSrcLang
LangObjc   -> (String
"objective-c",   [String]
userOpts_c
                        ,DynFlags -> String
pgm_c DynFlags
dflags   , String
"Objective C Compiler")
          ForeignSrcLang
LangObjcxx -> (String
"objective-c++", [String]
userOpts_cxx
                        ,DynFlags -> String
pgm_cxx DynFlags
dflags,  String
"Objective C++ Compiler")
          ForeignSrcLang
LangAsm    -> (String
"assembler",     []
                        ,DynFlags -> String
pgm_c DynFlags
dflags,    String
"Asm Compiler")
          ForeignSrcLang
RawObject  -> (String
"c",             []
                        ,DynFlags -> String
pgm_c DynFlags
dflags,    String
"C Compiler") -- claim C for lack of a better idea
          --JS backend shouldn't reach here, so we just pass
          -- strings to satisfy the totality checker
          ForeignSrcLang
LangJs     -> (String
"js",            []
                        ,DynFlags -> String
pgm_c DynFlags
dflags,    String
"JS Backend Compiler")
  userOpts_c :: [String]
userOpts_c   = DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_c
  userOpts_cxx :: [String]
userOpts_cxx = DynFlags -> (DynFlags -> [String]) -> [String]
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 = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
xs String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (String -> [String]
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 = Logger -> String -> IO String -> IO String
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
"linker" (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ do
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_l DynFlags
dflags
      args1 :: [Option]
args1     = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_l)
      args2 :: [Option]
args2     = [Option]
args0 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args1 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args
  mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
  runSomethingWith logger "gcc" p args2 $ \[String]
real_args ->
    CreateProcess -> IO (ExitCode, String)
readCreateProcessWithExitCode' (String -> [String] -> CreateProcess
proc String
p [String]
real_args){ env = mb_env }

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

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

-- | Run the LLVM Assembler
runLlvmAs :: Logger -> DynFlags -> [Option] -> IO ()
runLlvmAs :: Logger -> DynFlags -> [Option] -> IO ()
runLlvmAs Logger
logger DynFlags
dflags [Option]
args = Logger -> String -> IO () -> IO ()
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
"llvm-as" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_las DynFlags
dflags
      args1 :: [Option]
args1 = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_las)
  Logger -> String -> String -> [Option] -> IO ()
runSomething Logger
logger String
"LLVM assembler" String
p ([Option]
args0 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args1 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args)


runEmscripten :: Logger -> DynFlags -> [Option] -> IO ()
runEmscripten :: Logger -> DynFlags -> [Option] -> IO ()
runEmscripten Logger
logger DynFlags
dflags [Option]
args = Logger -> String -> IO () -> IO ()
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
"emcc" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let (String
p,[Option]
args0) = DynFlags -> (String, [Option])
pgm_a DynFlags
dflags
      args1 :: [Option]
args1     = [Option]
args0 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args
  Logger -> String -> String -> [Option] -> IO ()
runSomething Logger
logger String
"Emscripten" String
p [Option]
args1

-- | 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 = Logger
-> String -> IO (Maybe LlvmVersion) -> IO (Maybe LlvmVersion)
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
"llc" (IO (Maybe LlvmVersion) -> IO (Maybe LlvmVersion))
-> IO (Maybe LlvmVersion) -> IO (Maybe LlvmVersion)
forall a b. (a -> b) -> a -> b
$ do
  let (String
pgm,[Option]
opts) = DynFlags -> (String, [Option])
pgm_lc DynFlags
dflags
      diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
      args :: [String]
args = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull ((Option -> String) -> [Option] -> [String]
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-version"]
  -- Since !12001, when GHC is not configured with llc/opt with
  -- supported version range, configure script will leave llc/opt
  -- commands as blank in settings. In this case, we should bail out
  -- with a proper error, see #25011.
  --
  -- Note that this does not make the -Wunsupported-llvm-version
  -- warning logic redundant! Power users might want to use
  -- -pgmlc/-pgmlo to override llc/opt locations to test LLVM outside
  -- officially supported version range, and the driver will produce
  -- the warning and carry on code generation.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pgm) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger (DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags) DiagOpts
diag_opts
      (DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> Messages DriverMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiagOpts -> [Warn] -> Messages DriverMessage
warnsToMessages DiagOpts
diag_opts [DriverMessage -> Warn
forall e. e -> Located e
noLoc DriverMessage
DriverNoConfiguredLLVMToolchain])
  IO (Maybe LlvmVersion)
-> (IOException -> IO (Maybe LlvmVersion))
-> IO (Maybe LlvmVersion)
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO (do
              (pin, pout, perr, p) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
pgm [String]
args'
                                              Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing
              {- > llc -version
                  LLVM (http://llvm.org/):
                    LLVM version 3.5.2
                    ...
              -}
              hSetBinaryMode pout False
              _     <- hGetLine pout
              vline <- hGetLine pout
              let mb_ver = String -> Maybe LlvmVersion
parseLlvmVersion String
vline
              hClose pin
              hClose pout
              hClose perr
              _ <- waitForProcess p
              return mb_ver
            )
            (\IOException
err -> do
                Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2
                    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Error (figuring out LLVM version):" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                      String -> SDoc
forall doc. IsLine doc => String -> doc
text (IOException -> String
forall a. Show a => a -> String
show IOException
err))
                Logger -> SDoc -> IO ()
errorMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
                    [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Warning:", Int -> SDoc -> SDoc
nest Int
9 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Couldn't figure out LLVM version!" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                          String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Make sure you have installed LLVM between ["
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersionLowerBound
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ LlvmVersion -> String
llvmVersionStr LlvmVersion
supportedLlvmVersionUpperBound
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") ]
                Maybe LlvmVersion -> IO (Maybe LlvmVersion)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LlvmVersion
forall a. Maybe a
Nothing)

-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runMergeObjects Logger
logger TmpFs
tmpfs DynFlags
dflags [Option]
args =
  Logger -> String -> IO () -> IO ()
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
"merge-objects" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let (String
p,[Option]
args0) = (String, [Option])
-> Maybe (String, [Option]) -> (String, [Option])
forall a. a -> Maybe a -> a
fromMaybe (String, [Option])
forall {b}. b
err (DynFlags -> Maybe (String, [Option])
pgm_lm DynFlags
dflags)
        err :: b
err = GhcException -> b
forall a. GhcException -> a
throwGhcException (GhcException -> b) -> GhcException -> b
forall a b. (a -> b) -> a -> b
$ String -> GhcException
UsageError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
            [ String
"Attempted to merge object files but the configured linker"
            , String
"does not support object merging." ]
        optl_args :: [Option]
optl_args = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_lm)
        args2 :: [Option]
args2     = [Option]
args0 [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
optl_args
    if ToolSettings -> Bool
toolSettings_mergeObjsSupportsResponseFiles (DynFlags -> ToolSettings
toolSettings DynFlags
dflags)
      then do
        mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
args2
        runSomethingResponseFile logger tmpfs (tmpDir dflags) id "Merge objects" p args2 mb_env
      else do
        Logger -> String -> String -> [Option] -> IO ()
runSomething Logger
logger String
"Merge objects" String
p [Option]
args2

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

askOtool :: Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO String
askOtool :: Logger -> ToolSettings -> Maybe String -> [Option] -> IO String
askOtool Logger
logger ToolSettings
toolSettings Maybe String
mb_cwd [Option]
args = do
  let otool :: String
otool = ToolSettings -> String
toolSettings_pgm_otool ToolSettings
toolSettings
  Logger
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, String))
-> IO String
forall a.
Logger
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger String
"otool" String
otool [Option]
args (([String] -> IO (ExitCode, String)) -> IO String)
-> ([String] -> IO (ExitCode, String)) -> IO String
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 = mb_cwd }

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

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

runWindres :: Logger -> DynFlags -> [Option] -> IO ()
runWindres :: Logger -> DynFlags -> [Option] -> IO ()
runWindres Logger
logger DynFlags
dflags [Option]
args = Logger -> String -> IO () -> IO ()
forall a. Logger -> String -> IO a -> IO a
traceSystoolCommand Logger
logger String
"windres" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let cc_args :: [Option]
cc_args = (String -> Option) -> [String] -> [Option]
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 = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
Option (DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_windres)
  mb_env <- [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
cc_args
  runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env