{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns #-}
{-# OPTIONS_GHC -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly

-----------------------------------------------------------------------------
--
-- GHC Driver
--
-- (c) The University of Glasgow 2005
--
-----------------------------------------------------------------------------

module DriverPipeline (
        -- Run a series of compilation steps in a pipeline, for a
        -- collection of source files.
   oneShot, compileFile,

        -- Interfaces for the batch-mode driver
   linkBinary,

        -- Interfaces for the compilation manager (interpreted/batch-mode)
   preprocess,
   compileOne, compileOne',
   link,

        -- Exports for hooks to override runPhase and link
   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
   runPhase, exeFileName,
   maybeCreateManifest,
   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
  ) where

#include "HsVersions.h"

import GhcPrelude

import PipelineMonad
import Packages
import HeaderInfo
import DriverPhases
import SysTools
import SysTools.ExtraObj
import HscMain
import Finder
import HscTypes hiding ( Hsc )
import Outputable
import Module
import ErrUtils
import DynFlags
import Config
import Panic
import Util
import StringBuffer     ( hGetStringBuffer, hPutStringBuffer )
import BasicTypes       ( SuccessFlag(..) )
import Maybes           ( expectJust )
import SrcLoc
import LlvmCodeGen      ( LlvmVersion (..), llvmFixupAsm )
import MonadUtils
import Platform
import TcRnTypes
import Hooks
import qualified GHC.LanguageExtensions as LangExt
import FileCleanup
import Ar
import Bag              ( unitBag )
import FastString       ( mkFastString )

import Exception
import System.Directory
import System.FilePath
import System.IO
import Control.Monad
import Data.List        ( isInfixOf, isSuffixOf, intercalate )
import Data.Maybe
import Data.Version
import Data.Either      ( partitionEithers )

import Data.Time        ( UTCTime )

-- ---------------------------------------------------------------------------
-- Pre-process

-- | Just preprocess a file, put the result in a temp. file (used by the
-- compilation manager during the summary phase).
--
-- We return the augmented DynFlags, because they contain the result
-- of slurping in the OPTIONS pragmas

preprocess :: HscEnv
           -> FilePath -- ^ input filename
           -> Maybe InputFileBuffer
           -- ^ optional buffer to use instead of reading the input file
           -> Maybe Phase -- ^ starting phase
           -> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess :: HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess hsc_env :: HscEnv
hsc_env input_fn :: FilePath
input_fn mb_input_buf :: Maybe InputFileBuffer
mb_input_buf mb_phase :: Maybe Phase
mb_phase =
  (SourceError -> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (m :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\err :: SourceError
err -> Either ErrorMessages (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorMessages -> Either ErrorMessages (DynFlags, FilePath)
forall a b. a -> Either a b
Left (SourceError -> ErrorMessages
srcErrorMessages SourceError
err))) (IO (Either ErrorMessages (DynFlags, FilePath))
 -> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$
  (GhcException -> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (m :: * -> *) e a.
(ExceptionMonad m, Exception e) =>
(e -> m a) -> m a -> m a
ghandle GhcException -> IO (Either ErrorMessages (DynFlags, FilePath))
forall b. GhcException -> IO (Either ErrorMessages b)
handler (IO (Either ErrorMessages (DynFlags, FilePath))
 -> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$
  ((DynFlags, FilePath) -> Either ErrorMessages (DynFlags, FilePath))
-> IO (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags, FilePath) -> Either ErrorMessages (DynFlags, FilePath)
forall a b. b -> Either a b
Right (IO (DynFlags, FilePath)
 -> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$
  ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
  Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline Phase
anyHsc HscEnv
hsc_env (FilePath
input_fn, Maybe InputFileBuffer
mb_input_buf, (Phase -> PhasePlus) -> Maybe Phase -> Maybe PhasePlus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Phase -> PhasePlus
RealPhase Maybe Phase
mb_phase)
        Maybe FilePath
forall a. Maybe a
Nothing
        -- We keep the processed file for the whole session to save on
        -- duplicated work in ghci.
        (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_GhcSession)
        Maybe ModLocation
forall a. Maybe a
Nothing{-no ModLocation-}
        []{-no foreign objects-}
  where
    srcspan :: SrcSpan
srcspan = SrcLoc -> SrcSpan
srcLocSpan (SrcLoc -> SrcSpan) -> SrcLoc -> SrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
mkFastString FilePath
input_fn) 1 1
    handler :: GhcException -> IO (Either ErrorMessages b)
handler (ProgramError msg :: FilePath
msg) = Either ErrorMessages b -> IO (Either ErrorMessages b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages b -> IO (Either ErrorMessages b))
-> Either ErrorMessages b -> IO (Either ErrorMessages b)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages b
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages b)
-> ErrorMessages -> Either ErrorMessages b
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrorMessages
forall a. a -> Bag a
unitBag (ErrMsg -> ErrorMessages) -> ErrMsg -> ErrorMessages
forall a b. (a -> b) -> a -> b
$
        DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
srcspan (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
msg
    handler ex :: GhcException
ex = GhcException -> IO (Either ErrorMessages b)
forall a. GhcException -> IO a
throwGhcExceptionIO GhcException
ex

-- ---------------------------------------------------------------------------

-- | Compile
--
-- Compile a single module, under the control of the compilation manager.
--
-- This is the interface between the compilation manager and the
-- compiler proper (hsc), where we deal with tedious details like
-- reading the OPTIONS pragma from the source file, converting the
-- C or assembly that GHC produces into an object file, and compiling
-- FFI stub files.
--
-- NB.  No old interface can also mean that the source has changed.

compileOne :: HscEnv
           -> ModSummary      -- ^ summary for module being compiled
           -> Int             -- ^ module N ...
           -> Int             -- ^ ... of M
           -> Maybe ModIface  -- ^ old interface, if we have one
           -> Maybe Linkable  -- ^ old linkable, if we have one
           -> SourceModified
           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful

compileOne :: HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne = Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
forall a. Maybe a
Nothing (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
batchMsg)

compileOne' :: Maybe TcGblEnv
            -> Maybe Messager
            -> HscEnv
            -> ModSummary      -- ^ summary for module being compiled
            -> Int             -- ^ module N ...
            -> Int             -- ^ ... of M
            -> Maybe ModIface  -- ^ old interface, if we have one
            -> Maybe Linkable  -- ^ old linkable, if we have one
            -> SourceModified
            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful

compileOne' :: Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' m_tc_result :: Maybe TcGblEnv
m_tc_result mHscMessage :: Maybe Messager
mHscMessage
            hsc_env0 :: HscEnv
hsc_env0 summary :: ModSummary
summary mod_index :: Int
mod_index nmods :: Int
nmods mb_old_iface :: Maybe ModIface
mb_old_iface maybe_old_linkable :: Maybe Linkable
maybe_old_linkable
            source_modified0 :: SourceModified
source_modified0
 = do

   DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags1 2 (FilePath -> SDoc
text "compile: input file" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
input_fnpp)

   (status :: HscStatus
status, hmi0 :: HomeModInfo
hmi0) <- Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, HomeModInfo)
hscIncrementalCompile
                        Bool
always_do_basic_recompilation_check
                        Maybe TcGblEnv
m_tc_result Maybe Messager
mHscMessage
                        HscEnv
hsc_env ModSummary
summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int
mod_index, Int
nmods)

   let flags :: DynFlags
flags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env0
     in do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepHiFiles DynFlags
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
               DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean DynFlags
flags TempFileLifetime
TFL_CurrentModule ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$
                   [ModLocation -> FilePath
ml_hi_file (ModLocation -> FilePath) -> ModLocation -> FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
summary]
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepOFiles DynFlags
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
               DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean DynFlags
flags TempFileLifetime
TFL_GhcSession ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$
                   [ModLocation -> FilePath
ml_obj_file (ModLocation -> FilePath) -> ModLocation -> FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
summary]

   case (HscStatus
status, HscTarget
hsc_lang) of
        (HscUpToDate, _) ->
            -- TODO recomp014 triggers this assert. What's going on?!
            -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi0 { hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
maybe_old_linkable }
        (HscNotGeneratingCode, HscNothing) ->
            let mb_linkable :: Maybe Linkable
mb_linkable = if HscSource -> Bool
isHsBootOrSig HscSource
src_flavour
                                then Maybe Linkable
forall a. Maybe a
Nothing
                                -- TODO: Questionable.
                                else Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just (UTCTime -> Module -> [Unlinked] -> Linkable
LM (ModSummary -> UTCTime
ms_hs_date ModSummary
summary) Module
this_mod [])
            in HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi0 { hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
mb_linkable }
        (HscNotGeneratingCode, _) -> FilePath -> IO HomeModInfo
forall a. FilePath -> a
panic "compileOne HscNotGeneratingCode"
        (_, HscNothing) -> FilePath -> IO HomeModInfo
forall a. FilePath -> a
panic "compileOne HscNothing"
        (HscUpdateBoot, HscInterpreted) -> do
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi0
        (HscUpdateBoot, _) -> do
            DynFlags -> FilePath -> IO ()
touchObjectFile DynFlags
dflags FilePath
object_filename
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi0
        (HscUpdateSig, HscInterpreted) ->
            let linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM (ModSummary -> UTCTime
ms_hs_date ModSummary
summary) Module
this_mod []
            in HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi0 { hm_linkable :: Maybe Linkable
hm_linkable = Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable }
        (HscUpdateSig, _) -> do
            FilePath
output_fn <- Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename Phase
next_phase
                            (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule) FilePath
basename DynFlags
dflags
                            Phase
next_phase (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)

            -- #10660: Use the pipeline instead of calling
            -- compileEmptyStub directly, so -dynamic-too gets
            -- handled properly
            (DynFlags, FilePath)
_ <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline Phase
StopLn HscEnv
hsc_env
                              (FilePath
output_fn,
                               Maybe InputFileBuffer
forall a. Maybe a
Nothing,
                               PhasePlus -> Maybe PhasePlus
forall a. a -> Maybe a
Just (HscSource -> ModuleName -> HscStatus -> PhasePlus
HscOut HscSource
src_flavour
                                            ModuleName
mod_name HscStatus
HscUpdateSig))
                              (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
basename)
                              PipelineOutput
Persistent
                              (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
                              []
            UTCTime
o_time <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
object_filename
            let linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
o_time Module
this_mod [FilePath -> Unlinked
DotO FilePath
object_filename]
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi0 { hm_linkable :: Maybe Linkable
hm_linkable = Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable }
        (HscRecomp cgguts :: CgGuts
cgguts summary :: ModSummary
summary, HscInterpreted) -> do
            (hasStub :: Maybe FilePath
hasStub, comp_bc :: CompiledByteCode
comp_bc, spt_entries :: [SptEntry]
spt_entries) <-
                HscEnv
-> CgGuts
-> ModSummary
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive HscEnv
hsc_env CgGuts
cgguts ModSummary
summary

            [Unlinked]
stub_o <- case Maybe FilePath
hasStub of
                      Nothing -> [Unlinked] -> IO [Unlinked]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                      Just stub_c :: FilePath
stub_c -> do
                          FilePath
stub_o <- HscEnv -> FilePath -> IO FilePath
compileStub HscEnv
hsc_env FilePath
stub_c
                          [Unlinked] -> IO [Unlinked]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> Unlinked
DotO FilePath
stub_o]

            let hs_unlinked :: [Unlinked]
hs_unlinked = [CompiledByteCode -> [SptEntry] -> Unlinked
BCOs CompiledByteCode
comp_bc [SptEntry]
spt_entries]
                unlinked_time :: UTCTime
unlinked_time = ModSummary -> UTCTime
ms_hs_date ModSummary
summary
              -- Why do we use the timestamp of the source file here,
              -- rather than the current time?  This works better in
              -- the case where the local clock is out of sync
              -- with the filesystem's clock.  It's just as accurate:
              -- if the source is modified, then the linkable will
              -- be out of date.
            let linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
unlinked_time (ModSummary -> Module
ms_mod ModSummary
summary)
                           ([Unlinked]
hs_unlinked [Unlinked] -> [Unlinked] -> [Unlinked]
forall a. [a] -> [a] -> [a]
++ [Unlinked]
stub_o)
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi0 { hm_linkable :: Maybe Linkable
hm_linkable = Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable }
        (HscRecomp cgguts :: CgGuts
cgguts summary :: ModSummary
summary, _) -> do
            FilePath
output_fn <- Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename Phase
next_phase
                            (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule)
                            FilePath
basename DynFlags
dflags Phase
next_phase (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
            -- We're in --make mode: finish the compilation pipeline.
            (DynFlags, FilePath)
_ <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline Phase
StopLn HscEnv
hsc_env
                              (FilePath
output_fn,
                               Maybe InputFileBuffer
forall a. Maybe a
Nothing,
                               PhasePlus -> Maybe PhasePlus
forall a. a -> Maybe a
Just (HscSource -> ModuleName -> HscStatus -> PhasePlus
HscOut HscSource
src_flavour ModuleName
mod_name (CgGuts -> ModSummary -> HscStatus
HscRecomp CgGuts
cgguts ModSummary
summary)))
                              (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
basename)
                              PipelineOutput
Persistent
                              (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
                              []
                  -- The object filename comes from the ModLocation
            UTCTime
o_time <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
object_filename
            let linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
o_time Module
this_mod [FilePath -> Unlinked
DotO FilePath
object_filename]
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi0 { hm_linkable :: Maybe Linkable
hm_linkable = Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable }

 where dflags0 :: DynFlags
dflags0     = ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary

       this_mod :: Module
this_mod    = ModSummary -> Module
ms_mod ModSummary
summary
       location :: ModLocation
location    = ModSummary -> ModLocation
ms_location ModSummary
summary
       input_fn :: FilePath
input_fn    = FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust "compile:hs" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location)
       input_fnpp :: FilePath
input_fnpp  = ModSummary -> FilePath
ms_hspp_file ModSummary
summary
       mod_graph :: ModuleGraph
mod_graph   = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env0
       needsLinker :: Bool
needsLinker = ModuleGraph -> Bool
needsTemplateHaskellOrQQ ModuleGraph
mod_graph
       isDynWay :: Bool
isDynWay    = (Way -> Bool) -> [Way] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
== Way
WayDyn) (DynFlags -> [Way]
ways DynFlags
dflags0)
       isProfWay :: Bool
isProfWay   = (Way -> Bool) -> [Way] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
== Way
WayProf) (DynFlags -> [Way]
ways DynFlags
dflags0)
       internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags0)

       src_flavour :: HscSource
src_flavour = ModSummary -> HscSource
ms_hsc_src ModSummary
summary
       mod_name :: ModuleName
mod_name = ModSummary -> ModuleName
ms_mod_name ModSummary
summary
       next_phase :: Phase
next_phase = DynFlags -> HscSource -> HscTarget -> Phase
hscPostBackendPhase DynFlags
dflags HscSource
src_flavour HscTarget
hsc_lang
       object_filename :: FilePath
object_filename = ModLocation -> FilePath
ml_obj_file ModLocation
location

       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
       -- the linker can correctly load the object files.  This isn't necessary
       -- when using -fexternal-interpreter.
       dflags1 :: DynFlags
dflags1 = if Bool
dynamicGhc Bool -> Bool -> Bool
&& Bool
internalInterpreter Bool -> Bool -> Bool
&&
                    Bool -> Bool
not Bool
isDynWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isProfWay Bool -> Bool -> Bool
&& Bool
needsLinker
                  then DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags0 GeneralFlag
Opt_BuildDynamicToo
                  else DynFlags
dflags0

       -- #16331 - when no "internal interpreter" is available but we
       -- need to process some TemplateHaskell or QuasiQuotes, we automatically
       -- turn on -fexternal-interpreter.
       dflags2 :: DynFlags
dflags2 = if Bool -> Bool
not Bool
internalInterpreter Bool -> Bool -> Bool
&& Bool
needsLinker
                 then DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags1 GeneralFlag
Opt_ExternalInterpreter
                 else DynFlags
dflags1

       basename :: FilePath
basename = FilePath -> FilePath
dropExtension FilePath
input_fn

       -- We add the directory in which the .hs files resides) to the import
       -- path.  This is needed when we try to compile the .hc file later, if it
       -- imports a _stub.h file that we created here.
       current_dir :: FilePath
current_dir = FilePath -> FilePath
takeDirectory FilePath
basename
       old_paths :: IncludeSpecs
old_paths   = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags2
       !prevailing_dflags :: DynFlags
prevailing_dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env0
       dflags :: DynFlags
dflags =
          DynFlags
dflags2 { includePaths :: IncludeSpecs
includePaths = IncludeSpecs -> [FilePath] -> IncludeSpecs
addQuoteInclude IncludeSpecs
old_paths [FilePath
current_dir]
                  , log_action :: LogAction
log_action = DynFlags -> LogAction
log_action DynFlags
prevailing_dflags }
                  -- use the prevailing log_action / log_finaliser,
                  -- not the one cached in the summary.  This is so
                  -- that we can change the log_action without having
                  -- to re-summarize all the source files.
       hsc_env :: HscEnv
hsc_env     = HscEnv
hsc_env0 {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags}

       -- Figure out what lang we're generating
       hsc_lang :: HscTarget
hsc_lang = DynFlags -> HscTarget
hscTarget DynFlags
dflags

       -- -fforce-recomp should also work with --make
       force_recomp :: Bool
force_recomp = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp DynFlags
dflags
       source_modified :: SourceModified
source_modified
         | Bool
force_recomp = SourceModified
SourceModified
         | Bool
otherwise = SourceModified
source_modified0

       always_do_basic_recompilation_check :: Bool
always_do_basic_recompilation_check = case HscTarget
hsc_lang of
                                             HscInterpreted -> Bool
True
                                             _ -> Bool
False

-----------------------------------------------------------------------------
-- stub .h and .c files (for foreign export support), and cc files.

-- The _stub.c file is derived from the haskell source file, possibly taking
-- into account the -stubdir option.
--
-- The object file created by compiling the _stub.c file is put into a
-- temporary file, which will be later combined with the main .o file
-- (see the MergeForeigns phase).
--
-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
-- from TH, that are then compiled and linked to the module. This is
-- useful to implement facilities such as inline-c.

compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign _ RawObject object_file :: FilePath
object_file = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
object_file
compileForeign hsc_env :: HscEnv
hsc_env lang :: ForeignSrcLang
lang stub_c :: FilePath
stub_c = do
        let phase :: Phase
phase = case ForeignSrcLang
lang of
              LangC      -> Phase
Cc
              LangCxx    -> Phase
Ccxx
              LangObjc   -> Phase
Cobjc
              LangObjcxx -> Phase
Cobjcxx
              LangAsm    -> Bool -> Phase
As Bool
True -- allow CPP
              RawObject  -> FilePath -> Phase
forall a. FilePath -> a
panic "compileForeign: should be unreachable"
        (_, stub_o :: FilePath
stub_o) <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline Phase
StopLn HscEnv
hsc_env
                       (FilePath
stub_c, Maybe InputFileBuffer
forall a. Maybe a
Nothing, PhasePlus -> Maybe PhasePlus
forall a. a -> Maybe a
Just (Phase -> PhasePlus
RealPhase Phase
phase))
                       Maybe FilePath
forall a. Maybe a
Nothing (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_GhcSession)
                       Maybe ModLocation
forall a. Maybe a
Nothing{-no ModLocation-}
                       []
        FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
stub_o

compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub hsc_env :: HscEnv
hsc_env stub_c :: FilePath
stub_c = HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign HscEnv
hsc_env ForeignSrcLang
LangC FilePath
stub_c

compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub :: DynFlags
-> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub dflags :: DynFlags
dflags hsc_env :: HscEnv
hsc_env basename :: FilePath
basename location :: ModLocation
location mod_name :: ModuleName
mod_name = do
  -- To maintain the invariant that every Haskell file
  -- compiles to object code, we make an empty (but
  -- valid) stub object file for signatures.  However,
  -- we make sure this object file has a unique symbol,
  -- so that ranlib on OS X doesn't complain, see
  -- http://ghc.haskell.org/trac/ghc/ticket/12673
  -- and https://github.com/haskell/cabal/issues/2257
  FilePath
empty_stub <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule "c"
  let src :: SDoc
src = FilePath -> SDoc
text "int" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
dflags) ModuleName
mod_name) SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "= 0;"
  FilePath -> FilePath -> IO ()
writeFile FilePath
empty_stub (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
CStyle SDoc
src))
  (DynFlags, FilePath)
_ <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline Phase
StopLn HscEnv
hsc_env
                  (FilePath
empty_stub, Maybe InputFileBuffer
forall a. Maybe a
Nothing, Maybe PhasePlus
forall a. Maybe a
Nothing)
                  (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
basename)
                  PipelineOutput
Persistent
                  (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
                  []
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- ---------------------------------------------------------------------------
-- Link

link :: GhcLink                 -- interactive or batch
     -> DynFlags                -- dynamic flags
     -> Bool                    -- attempt linking in batch mode?
     -> HomePackageTable        -- what to link
     -> IO SuccessFlag

-- For the moment, in the batch linker, we don't bother to tell doLink
-- which packages to link -- it just tries all that are available.
-- batch_attempt_linking should only be *looked at* in batch mode.  It
-- should only be True if the upsweep was successful and someone
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.

link :: GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link ghcLink :: GhcLink
ghcLink dflags :: DynFlags
dflags
  = (Hooks
 -> Maybe
      (GhcLink
       -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag))
-> (GhcLink
    -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
-> DynFlags
-> GhcLink
-> DynFlags
-> Bool
-> HomePackageTable
-> IO SuccessFlag
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks
-> Maybe
     (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
linkHook GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
l DynFlags
dflags GhcLink
ghcLink DynFlags
dflags
  where
    l :: GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
l LinkInMemory _ _ _
      = if FilePath
cGhcWithInterpreter FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "YES"
        then -- Not Linking...(demand linker will do the job)
             SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
        else GhcLink -> IO SuccessFlag
forall a. GhcLink -> a
panicBadLink GhcLink
LinkInMemory

    l NoLink _ _ _
      = SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded

    l LinkBinary dflags :: DynFlags
dflags batch_attempt_linking :: Bool
batch_attempt_linking hpt :: HomePackageTable
hpt
      = DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link' DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt

    l LinkStaticLib dflags :: DynFlags
dflags batch_attempt_linking :: Bool
batch_attempt_linking hpt :: HomePackageTable
hpt
      = DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link' DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt

    l LinkDynLib dflags :: DynFlags
dflags batch_attempt_linking :: Bool
batch_attempt_linking hpt :: HomePackageTable
hpt
      = DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link' DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt

panicBadLink :: GhcLink -> a
panicBadLink :: GhcLink -> a
panicBadLink other :: GhcLink
other = FilePath -> a
forall a. FilePath -> a
panic ("link: GHC not built to link this way: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                            GhcLink -> FilePath
forall a. Show a => a -> FilePath
show GhcLink
other)

link' :: DynFlags                -- dynamic flags
      -> Bool                    -- attempt linking in batch mode?
      -> HomePackageTable        -- what to link
      -> IO SuccessFlag

link' :: DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link' dflags :: DynFlags
dflags batch_attempt_linking :: Bool
batch_attempt_linking hpt :: HomePackageTable
hpt
   | Bool
batch_attempt_linking
   = do
        let
            staticLink :: Bool
staticLink = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
                          LinkStaticLib -> Bool
True
                          _ -> Bool
False

            home_mod_infos :: [HomeModInfo]
home_mod_infos = HomePackageTable -> [HomeModInfo]
eltsHpt HomePackageTable
hpt

            -- the packages we depend on
            pkg_deps :: [InstalledUnitId]
pkg_deps  = (HomeModInfo -> [InstalledUnitId])
-> [HomeModInfo] -> [InstalledUnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((InstalledUnitId, Bool) -> InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst ([(InstalledUnitId, Bool)] -> [InstalledUnitId])
-> (HomeModInfo -> [(InstalledUnitId, Bool)])
-> HomeModInfo
-> [InstalledUnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(InstalledUnitId, Bool)]
dep_pkgs (Dependencies -> [(InstalledUnitId, Bool)])
-> (HomeModInfo -> Dependencies)
-> HomeModInfo
-> [(InstalledUnitId, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Dependencies
mi_deps (ModIface -> Dependencies)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Dependencies
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
home_mod_infos

            -- the linkables to link
            linkables :: [Linkable]
linkables = (HomeModInfo -> Linkable) -> [HomeModInfo] -> [Linkable]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe Linkable -> Linkable
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust "link"(Maybe Linkable -> Linkable)
-> (HomeModInfo -> Maybe Linkable) -> HomeModInfo -> Linkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> Maybe Linkable
hm_linkable) [HomeModInfo]
home_mod_infos

        DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 3 (FilePath -> SDoc
text "link: linkables are ..." SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((Linkable -> SDoc) -> [Linkable] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Linkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Linkable]
linkables))

        -- check for the -no-link flag
        if GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
          then do DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 3 (FilePath -> SDoc
text "link(batch): linking omitted (-c flag given).")
                  SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
          else do

        let getOfiles :: Linkable -> [FilePath]
getOfiles (LM _ _ us :: [Unlinked]
us) = (Unlinked -> FilePath) -> [Unlinked] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Unlinked -> FilePath
nameOfObject ((Unlinked -> Bool) -> [Unlinked] -> [Unlinked]
forall a. (a -> Bool) -> [a] -> [a]
filter Unlinked -> Bool
isObject [Unlinked]
us)
            obj_files :: [FilePath]
obj_files = (Linkable -> [FilePath]) -> [Linkable] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Linkable -> [FilePath]
getOfiles [Linkable]
linkables

            exe_file :: FilePath
exe_file = Bool -> DynFlags -> FilePath
exeFileName Bool
staticLink DynFlags
dflags

        Bool
linking_needed <- DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
linkingNeeded DynFlags
dflags Bool
staticLink [Linkable]
linkables [InstalledUnitId]
pkg_deps

        if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp DynFlags
dflags) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
linking_needed
           then do DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (FilePath -> SDoc
text FilePath
exe_file SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "is up to date, linking not required.")
                   SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
           else do

        DynFlags -> FilePath -> IO ()
compilationProgressMsg DynFlags
dflags ("Linking " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
exe_file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " ...")

        -- Don't showPass in Batch mode; doLink will do that for us.
        let link :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
link = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
                LinkBinary    -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary
                LinkStaticLib -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkStaticLib
                LinkDynLib    -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkDynLibCheck
                other :: GhcLink
other         -> GhcLink -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
forall a. GhcLink -> a
panicBadLink GhcLink
other
        DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
link DynFlags
dflags [FilePath]
obj_files [InstalledUnitId]
pkg_deps

        DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 3 (FilePath -> SDoc
text "link: done")

        -- linkBinary only returns if it succeeds
        SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded

   | Bool
otherwise
   = do DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 3 (FilePath -> SDoc
text "link(batch): upsweep (partially) failed OR" SDoc -> SDoc -> SDoc
$$
                                FilePath -> SDoc
text "   Main.main not exported; not linking.")
        SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded


linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
linkingNeeded dflags :: DynFlags
dflags staticLink :: Bool
staticLink linkables :: [Linkable]
linkables pkg_deps :: [InstalledUnitId]
pkg_deps = do
        -- if the modification time on the executable is later than the
        -- modification times on all of the objects and libraries, then omit
        -- linking (unless the -fforce-recomp flag was given).
  let exe_file :: FilePath
exe_file = Bool -> DynFlags -> FilePath
exeFileName Bool
staticLink DynFlags
dflags
  Either IOException UTCTime
e_exe_time <- IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
tryIO (IO UTCTime -> IO (Either IOException UTCTime))
-> IO UTCTime -> IO (Either IOException UTCTime)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime FilePath
exe_file
  case Either IOException UTCTime
e_exe_time of
    Left _  -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Right t :: UTCTime
t -> do
        -- first check object files and extra_ld_inputs
        let extra_ld_inputs :: [FilePath]
extra_ld_inputs = [ FilePath
f | FileOption _ f :: FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
        [Either IOException UTCTime]
e_extra_times <- (FilePath -> IO (Either IOException UTCTime))
-> [FilePath] -> IO [Either IOException UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
tryIO (IO UTCTime -> IO (Either IOException UTCTime))
-> (FilePath -> IO UTCTime)
-> FilePath
-> IO (Either IOException UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO UTCTime
getModificationUTCTime) [FilePath]
extra_ld_inputs
        let (errs :: [IOException]
errs,extra_times :: [UTCTime]
extra_times) = [Either IOException UTCTime] -> ([IOException], [UTCTime])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either IOException UTCTime]
e_extra_times
        let obj_times :: [UTCTime]
obj_times =  (Linkable -> UTCTime) -> [Linkable] -> [UTCTime]
forall a b. (a -> b) -> [a] -> [b]
map Linkable -> UTCTime
linkableTime [Linkable]
linkables [UTCTime] -> [UTCTime] -> [UTCTime]
forall a. [a] -> [a] -> [a]
++ [UTCTime]
extra_times
        if Bool -> Bool
not ([IOException] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IOException]
errs) Bool -> Bool -> Bool
|| (UTCTime -> Bool) -> [UTCTime] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) [UTCTime]
obj_times
            then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else do

        -- next, check libraries. XXX this only checks Haskell libraries,
        -- not extra_libraries or -l things from the command line.
        let pkg_hslibs :: [([FilePath], FilePath)]
pkg_hslibs  = [ (DynFlags -> [PackageConfig] -> [FilePath]
collectLibraryPaths DynFlags
dflags [PackageConfig
c], FilePath
lib)
                          | Just c :: PackageConfig
c <- (InstalledUnitId -> Maybe PackageConfig)
-> [InstalledUnitId] -> [Maybe PackageConfig]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage DynFlags
dflags) [InstalledUnitId]
pkg_deps,
                            FilePath
lib <- DynFlags -> PackageConfig -> [FilePath]
packageHsLibs DynFlags
dflags PackageConfig
c ]

        [Maybe FilePath]
pkg_libfiles <- (([FilePath], FilePath) -> IO (Maybe FilePath))
-> [([FilePath], FilePath)] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([FilePath] -> FilePath -> IO (Maybe FilePath))
-> ([FilePath], FilePath) -> IO (Maybe FilePath)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DynFlags -> [FilePath] -> FilePath -> IO (Maybe FilePath)
findHSLib DynFlags
dflags)) [([FilePath], FilePath)]
pkg_hslibs
        if (Maybe FilePath -> Bool) -> [Maybe FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe FilePath]
pkg_libfiles then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else do
        [Either IOException UTCTime]
e_lib_times <- (FilePath -> IO (Either IOException UTCTime))
-> [FilePath] -> IO [Either IOException UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
tryIO (IO UTCTime -> IO (Either IOException UTCTime))
-> (FilePath -> IO UTCTime)
-> FilePath
-> IO (Either IOException UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO UTCTime
getModificationUTCTime)
                          ([Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes [Maybe FilePath]
pkg_libfiles)
        let (lib_errs :: [IOException]
lib_errs,lib_times :: [UTCTime]
lib_times) = [Either IOException UTCTime] -> ([IOException], [UTCTime])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either IOException UTCTime]
e_lib_times
        if Bool -> Bool
not ([IOException] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IOException]
lib_errs) Bool -> Bool -> Bool
|| (UTCTime -> Bool) -> [UTCTime] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) [UTCTime]
lib_times
           then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
           else DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool
checkLinkInfo DynFlags
dflags [InstalledUnitId]
pkg_deps FilePath
exe_file

findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
findHSLib :: DynFlags -> [FilePath] -> FilePath -> IO (Maybe FilePath)
findHSLib dflags :: DynFlags
dflags dirs :: [FilePath]
dirs lib :: FilePath
lib = do
  let batch_lib_file :: FilePath
batch_lib_file = if Way
WayDyn Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` DynFlags -> [Way]
ways DynFlags
dflags
                      then "lib" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
lib FilePath -> FilePath -> FilePath
<.> "a"
                      else Platform -> FilePath -> FilePath
mkSOName (DynFlags -> Platform
targetPlatform DynFlags
dflags) FilePath
lib
  [FilePath]
found <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
batch_lib_file) [FilePath]
dirs)
  case [FilePath]
found of
    [] -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
    (x :: FilePath
x:_) -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
x)

-- -----------------------------------------------------------------------------
-- Compile files in one-shot mode.

oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
oneShot :: HscEnv -> Phase -> [(FilePath, Maybe Phase)] -> IO ()
oneShot hsc_env :: HscEnv
hsc_env stop_phase :: Phase
stop_phase srcs :: [(FilePath, Maybe Phase)]
srcs = do
  [FilePath]
o_files <- ((FilePath, Maybe Phase) -> IO FilePath)
-> [(FilePath, Maybe Phase)] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile HscEnv
hsc_env Phase
stop_phase) [(FilePath, Maybe Phase)]
srcs
  DynFlags -> Phase -> [FilePath] -> IO ()
doLink (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Phase
stop_phase [FilePath]
o_files

compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile hsc_env :: HscEnv
hsc_env stop_phase :: Phase
stop_phase (src :: FilePath
src, mb_phase :: Maybe Phase
mb_phase) = do
   Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
src
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
exists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
CmdLineError ("does not exist: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
src))

   let
        dflags :: DynFlags
dflags    = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        split :: Bool
split     = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags
        mb_o_file :: Maybe FilePath
mb_o_file = DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
        ghc_link :: GhcLink
ghc_link  = DynFlags -> GhcLink
ghcLink DynFlags
dflags      -- Set by -c or -no-link

        -- When linking, the -o argument refers to the linker's output.
        -- otherwise, we use it as the name for the pipeline's output.
        output :: PipelineOutput
output
         -- If we are doing -fno-code, then act as if the output is
         -- 'Temporary'. This stops GHC trying to copy files to their
         -- final location.
         | HscTarget
HscNothing <- DynFlags -> HscTarget
hscTarget DynFlags
dflags = TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule
         | Phase
StopLn <- Phase
stop_phase, Bool -> Bool
not (GhcLink -> Bool
isNoLink GhcLink
ghc_link) = PipelineOutput
Persistent
                -- -o foo applies to linker
         | Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
mb_o_file = PipelineOutput
SpecificFile
                -- -o foo applies to the file we are compiling now
         | Bool
otherwise = PipelineOutput
Persistent

        stop_phase' :: Phase
stop_phase' = case Phase
stop_phase of
                        As _ | Bool
split -> Phase
SplitAs
                        _            -> Phase
stop_phase
   ( _, out_file :: FilePath
out_file) <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline Phase
stop_phase' HscEnv
hsc_env
                            (FilePath
src, Maybe InputFileBuffer
forall a. Maybe a
Nothing, (Phase -> PhasePlus) -> Maybe Phase -> Maybe PhasePlus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Phase -> PhasePlus
RealPhase Maybe Phase
mb_phase)
                            Maybe FilePath
forall a. Maybe a
Nothing
                            PipelineOutput
output
                            Maybe ModLocation
forall a. Maybe a
Nothing{-no ModLocation-} []
   FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
out_file


doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
doLink dflags :: DynFlags
dflags stop_phase :: Phase
stop_phase o_files :: [FilePath]
o_files
  | Bool -> Bool
not (Phase -> Bool
isStopLn Phase
stop_phase)
  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()           -- We stopped before the linking phase

  | Bool
otherwise
  = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
        NoLink        -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        LinkBinary    -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary         DynFlags
dflags [FilePath]
o_files []
        LinkStaticLib -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkStaticLib      DynFlags
dflags [FilePath]
o_files []
        LinkDynLib    -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkDynLibCheck    DynFlags
dflags [FilePath]
o_files []
        other :: GhcLink
other         -> GhcLink -> IO ()
forall a. GhcLink -> a
panicBadLink GhcLink
other


-- ---------------------------------------------------------------------------

-- | Run a compilation pipeline, consisting of multiple phases.
--
-- This is the interface to the compilation pipeline, which runs
-- a series of compilation steps on a single source file, specifying
-- at which stage to stop.
--
-- The DynFlags can be modified by phases in the pipeline (eg. by
-- OPTIONS_GHC pragmas), and the changes affect later phases in the
-- pipeline.
runPipeline
  :: Phase                      -- ^ When to stop
  -> HscEnv                     -- ^ Compilation environment
  -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
                                -- ^ Pipeline input file name, optional
                                -- buffer and maybe -x suffix
  -> Maybe FilePath             -- ^ original basename (if different from ^^^)
  -> PipelineOutput             -- ^ Output filename
  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
  -> [FilePath]                 -- ^ foreign objects
  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
runPipeline :: Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline stop_phase :: Phase
stop_phase hsc_env0 :: HscEnv
hsc_env0 (input_fn :: FilePath
input_fn, mb_input_buf :: Maybe InputFileBuffer
mb_input_buf, mb_phase :: Maybe PhasePlus
mb_phase)
             mb_basename :: Maybe FilePath
mb_basename output :: PipelineOutput
output maybe_loc :: Maybe ModLocation
maybe_loc foreign_os :: [FilePath]
foreign_os

    = do let
             dflags0 :: DynFlags
dflags0 = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env0

             -- Decide where dump files should go based on the pipeline output
             dflags :: DynFlags
dflags = DynFlags
dflags0 { dumpPrefix :: Maybe FilePath
dumpPrefix = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
basename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".") }
             hsc_env :: HscEnv
hsc_env = HscEnv
hsc_env0 {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags}

             (input_basename :: FilePath
input_basename, suffix :: FilePath
suffix) = FilePath -> (FilePath, FilePath)
splitExtension FilePath
input_fn
             suffix' :: FilePath
suffix' = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 FilePath
suffix -- strip off the .
             basename :: FilePath
basename | Just b :: FilePath
b <- Maybe FilePath
mb_basename = FilePath
b
                      | Bool
otherwise             = FilePath
input_basename

             -- If we were given a -x flag, then use that phase to start from
             start_phase :: PhasePlus
start_phase = PhasePlus -> Maybe PhasePlus -> PhasePlus
forall a. a -> Maybe a -> a
fromMaybe (Phase -> PhasePlus
RealPhase (FilePath -> Phase
startPhase FilePath
suffix')) Maybe PhasePlus
mb_phase

             isHaskell :: PhasePlus -> Bool
isHaskell (RealPhase (Unlit _)) = Bool
True
             isHaskell (RealPhase (Cpp   _)) = Bool
True
             isHaskell (RealPhase (HsPp  _)) = Bool
True
             isHaskell (RealPhase (Hsc   _)) = Bool
True
             isHaskell (HscOut {})           = Bool
True
             isHaskell _                     = Bool
False

             isHaskellishFile :: Bool
isHaskellishFile = PhasePlus -> Bool
isHaskell PhasePlus
start_phase

             env :: PipeEnv
env = PipeEnv :: Phase
-> FilePath -> FilePath -> FilePath -> PipelineOutput -> PipeEnv
PipeEnv{ Phase
stop_phase :: Phase
stop_phase :: Phase
stop_phase,
                            src_filename :: FilePath
src_filename = FilePath
input_fn,
                            src_basename :: FilePath
src_basename = FilePath
basename,
                            src_suffix :: FilePath
src_suffix = FilePath
suffix',
                            output_spec :: PipelineOutput
output_spec = PipelineOutput
output }

         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isBackpackishSuffix FilePath
suffix') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
UsageError
                       ("use --backpack to process " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input_fn))

         -- We want to catch cases of "you can't get there from here" before
         -- we start the pipeline, because otherwise it will just run off the
         -- end.
         let happensBefore' :: Phase -> Phase -> Bool
happensBefore' = DynFlags -> Phase -> Phase -> Bool
happensBefore DynFlags
dflags
         case PhasePlus
start_phase of
             RealPhase start_phase' :: Phase
start_phase' ->
                 -- See Note [Partial ordering on phases]
                 -- Not the same as: (stop_phase `happensBefore` start_phase')
                 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Phase
start_phase' Phase -> Phase -> Bool
`happensBefore'` Phase
stop_phase Bool -> Bool -> Bool
||
                            Phase
start_phase' Phase -> Phase -> Bool
`eqPhase` Phase
stop_phase)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                       GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
UsageError
                                   ("cannot compile this file to desired target: "
                                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input_fn))
             HscOut {} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

         -- Write input buffer to temp file if requested
         FilePath
input_fn' <- case (PhasePlus
start_phase, Maybe InputFileBuffer
mb_input_buf) of
             (RealPhase real_start_phase :: Phase
real_start_phase, Just input_buf :: InputFileBuffer
input_buf) -> do
                 let suffix :: FilePath
suffix = Phase -> FilePath
phaseInputExt Phase
real_start_phase
                 FilePath
fn <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
suffix
                 Handle
hdl <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
fn IOMode
WriteMode
                 -- Add a LINE pragma so reported source locations will
                 -- mention the real input file, not this temp file.
                 Handle -> FilePath -> IO ()
hPutStrLn Handle
hdl (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "{-# LINE 1 \""FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input_fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\"#-}"
                 Handle -> InputFileBuffer -> IO ()
hPutStringBuffer Handle
hdl InputFileBuffer
input_buf
                 Handle -> IO ()
hClose Handle
hdl
                 FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fn
             (_, _) -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
input_fn

         DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 4 (FilePath -> SDoc
text "Running the pipeline")
         (DynFlags, FilePath)
r <- PhasePlus
-> HscEnv
-> PipeEnv
-> FilePath
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline' PhasePlus
start_phase HscEnv
hsc_env PipeEnv
env FilePath
input_fn'
                           Maybe ModLocation
maybe_loc [FilePath]
foreign_os

         -- If we are compiling a Haskell module, and doing
         -- -dynamic-too, but couldn't do the -dynamic-too fast
         -- path, then rerun the pipeline for the dyn way
         let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
         -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHaskellishFile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO () -> IO ()
forall (m :: * -> *). MonadIO m => DynFlags -> m () -> m ()
whenCannotGenerateDynamicToo DynFlags
dflags (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
               DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 4
                   (FilePath -> SDoc
text "Running the pipeline again for -dynamic-too")
               let dflags' :: DynFlags
dflags' = DynFlags -> DynFlags
dynamicTooMkDynamicDynFlags DynFlags
dflags
               HscEnv
hsc_env' <- DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags'
               (DynFlags, FilePath)
_ <- PhasePlus
-> HscEnv
-> PipeEnv
-> FilePath
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline' PhasePlus
start_phase HscEnv
hsc_env' PipeEnv
env FilePath
input_fn'
                                 Maybe ModLocation
maybe_loc [FilePath]
foreign_os
               () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         (DynFlags, FilePath) -> IO (DynFlags, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags, FilePath)
r

runPipeline'
  :: PhasePlus                  -- ^ When to start
  -> HscEnv                     -- ^ Compilation environment
  -> PipeEnv
  -> FilePath                   -- ^ Input filename
  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
  -> [FilePath]                 -- ^ foreign objects, if we have one
  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
runPipeline' :: PhasePlus
-> HscEnv
-> PipeEnv
-> FilePath
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath)
runPipeline' start_phase :: PhasePlus
start_phase hsc_env :: HscEnv
hsc_env env :: PipeEnv
env input_fn :: FilePath
input_fn
             maybe_loc :: Maybe ModLocation
maybe_loc foreign_os :: [FilePath]
foreign_os
  = do
  -- Execute the pipeline...
  let state :: PipeState
state = PipeState :: HscEnv -> Maybe ModLocation -> [FilePath] -> PipeState
PipeState{ HscEnv
hsc_env :: HscEnv
hsc_env :: HscEnv
hsc_env, Maybe ModLocation
maybe_loc :: Maybe ModLocation
maybe_loc :: Maybe ModLocation
maybe_loc, foreign_os :: [FilePath]
foreign_os = [FilePath]
foreign_os }

  CompPipeline (DynFlags, FilePath)
-> PipeEnv -> PipeState -> IO (DynFlags, FilePath)
forall a. CompPipeline a -> PipeEnv -> PipeState -> IO a
evalP (PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
pipeLoop PhasePlus
start_phase FilePath
input_fn) PipeEnv
env PipeState
state

-- ---------------------------------------------------------------------------
-- outer pipeline loop

-- | pipeLoop runs phases until we reach the stop phase
pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
pipeLoop phase :: PhasePlus
phase input_fn :: FilePath
input_fn = do
  PipeEnv
env <- CompPipeline PipeEnv
getPipeEnv
  DynFlags
dflags <- CompPipeline DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  -- See Note [Partial ordering on phases]
  let happensBefore' :: Phase -> Phase -> Bool
happensBefore' = DynFlags -> Phase -> Phase -> Bool
happensBefore DynFlags
dflags
      stopPhase :: Phase
stopPhase = PipeEnv -> Phase
stop_phase PipeEnv
env
  case PhasePlus
phase of
   RealPhase realPhase :: Phase
realPhase | Phase
realPhase Phase -> Phase -> Bool
`eqPhase` Phase
stopPhase            -- All done
     -> -- Sometimes, a compilation phase doesn't actually generate any output
        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
        -- stage, but we wanted to keep the output, then we have to explicitly
        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
        -- further compilation stages can tell what the original filename was.
        case PipeEnv -> PipelineOutput
output_spec PipeEnv
env of
        Temporary _ ->
            (DynFlags, FilePath) -> CompPipeline (DynFlags, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags, FilePath
input_fn)
        output :: PipelineOutput
output ->
            do PipeState
pst <- CompPipeline PipeState
getPipeState
               FilePath
final_fn <- IO FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> CompPipeline FilePath)
-> IO FilePath -> CompPipeline FilePath
forall a b. (a -> b) -> a -> b
$ Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename
                                        Phase
stopPhase PipelineOutput
output (PipeEnv -> FilePath
src_basename PipeEnv
env)
                                        DynFlags
dflags Phase
stopPhase (PipeState -> Maybe ModLocation
maybe_loc PipeState
pst)
               Bool -> CompPipeline () -> CompPipeline ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
final_fn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
input_fn) (CompPipeline () -> CompPipeline ())
-> CompPipeline () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ do
                  let msg :: FilePath
msg = ("Copying `" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input_fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++"' to `" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
final_fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "'")
                      line_prag :: Maybe FilePath
line_prag = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just ("{-# LINE 1 \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PipeEnv -> FilePath
src_filename PipeEnv
env FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\" #-}\n")
                  IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> FilePath -> Maybe FilePath -> FilePath -> FilePath -> IO ()
copyWithHeader DynFlags
dflags FilePath
msg Maybe FilePath
line_prag FilePath
input_fn FilePath
final_fn
               (DynFlags, FilePath) -> CompPipeline (DynFlags, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags, FilePath
final_fn)


     | Bool -> Bool
not (Phase
realPhase Phase -> Phase -> Bool
`happensBefore'` Phase
stopPhase)
        -- Something has gone wrong.  We'll try to cover all the cases when
        -- this could happen, so if we reach here it is a panic.
        -- eg. it might happen if the -C flag is used on a source file that
        -- has {-# OPTIONS -fasm #-}.
     -> FilePath -> CompPipeline (DynFlags, FilePath)
forall a. FilePath -> a
panic ("pipeLoop: at phase " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Phase -> FilePath
forall a. Show a => a -> FilePath
show Phase
realPhase FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
           " but I wanted to stop at phase " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Phase -> FilePath
forall a. Show a => a -> FilePath
show Phase
stopPhase)

   _
     -> do IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 4
                                  (FilePath -> SDoc
text "Running phase" SDoc -> SDoc -> SDoc
<+> PhasePlus -> SDoc
forall a. Outputable a => a -> SDoc
ppr PhasePlus
phase)
           (next_phase :: PhasePlus
next_phase, output_fn :: FilePath
output_fn) <- PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
runHookedPhase PhasePlus
phase FilePath
input_fn DynFlags
dflags
           (DynFlags, FilePath)
r <- PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
pipeLoop PhasePlus
next_phase FilePath
output_fn
           case PhasePlus
phase of
               HscOut {} ->
                   DynFlags -> CompPipeline () -> CompPipeline ()
forall (m :: * -> *). MonadIO m => DynFlags -> m () -> m ()
whenGeneratingDynamicToo DynFlags
dflags (CompPipeline () -> CompPipeline ())
-> CompPipeline () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ do
                       DynFlags -> CompPipeline ()
setDynFlags (DynFlags -> CompPipeline ()) -> DynFlags -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
dynamicTooMkDynamicDynFlags DynFlags
dflags
                       -- TODO shouldn't ignore result:
                       (DynFlags, FilePath)
_ <- PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
pipeLoop PhasePlus
phase FilePath
input_fn
                       () -> CompPipeline ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               _ ->
                   () -> CompPipeline ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           (DynFlags, FilePath) -> CompPipeline (DynFlags, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags, FilePath)
r

runHookedPhase :: PhasePlus -> FilePath -> DynFlags
               -> CompPipeline (PhasePlus, FilePath)
runHookedPhase :: PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
runHookedPhase pp :: PhasePlus
pp input :: FilePath
input dflags :: DynFlags
dflags =
  (Hooks
 -> Maybe
      (PhasePlus
       -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)))
-> (PhasePlus
    -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
-> DynFlags
-> PhasePlus
-> FilePath
-> DynFlags
-> CompPipeline (PhasePlus, FilePath)
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks
-> Maybe
     (PhasePlus
      -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
runPhaseHook PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
runPhase DynFlags
dflags PhasePlus
pp FilePath
input DynFlags
dflags

-- -----------------------------------------------------------------------------
-- In each phase, we need to know into what filename to generate the
-- output.  All the logic about which filenames we generate output
-- into is embodied in the following function.

-- | Computes the next output filename after we run @next_phase@.
-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad
-- (which specifies all of the ambient information.)
phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
phaseOutputFilename :: Phase -> CompPipeline FilePath
phaseOutputFilename next_phase :: Phase
next_phase = do
  PipeEnv{Phase
stop_phase :: Phase
stop_phase :: PipeEnv -> Phase
stop_phase, FilePath
src_basename :: FilePath
src_basename :: PipeEnv -> FilePath
src_basename, PipelineOutput
output_spec :: PipelineOutput
output_spec :: PipeEnv -> PipelineOutput
output_spec} <- CompPipeline PipeEnv
getPipeEnv
  PipeState{Maybe ModLocation
maybe_loc :: Maybe ModLocation
maybe_loc :: PipeState -> Maybe ModLocation
maybe_loc, HscEnv
hsc_env :: HscEnv
hsc_env :: PipeState -> HscEnv
hsc_env} <- CompPipeline PipeState
getPipeState
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  IO FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> CompPipeline FilePath)
-> IO FilePath -> CompPipeline FilePath
forall a b. (a -> b) -> a -> b
$ Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename Phase
stop_phase PipelineOutput
output_spec
                             FilePath
src_basename DynFlags
dflags Phase
next_phase Maybe ModLocation
maybe_loc

-- | Computes the next output filename for something in the compilation
-- pipeline.  This is controlled by several variables:
--
--      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This
--         is used to tell if we're in the last phase or not, because
--         in that case flags like @-o@ may be important.
--      2. 'PipelineOutput': is this intended to be a 'Temporary' or
--         'Persistent' build output?  Temporary files just go in
--         a fresh temporary name.
--      3. 'String': what was the basename of the original input file?
--      4. 'DynFlags': the obvious thing
--      5. 'Phase': the phase we want to determine the output filename of.
--      6. @Maybe ModLocation@: the 'ModLocation' of the module we're
--         compiling; this can be used to override the default output
--         of an object file.  (TODO: do we actually need this?)
getOutputFilename
  :: Phase -> PipelineOutput -> String
  -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
getOutputFilename :: Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename stop_phase :: Phase
stop_phase output :: PipelineOutput
output basename :: FilePath
basename dflags :: DynFlags
dflags next_phase :: Phase
next_phase maybe_location :: Maybe ModLocation
maybe_location
 | Bool
is_last_phase, PipelineOutput
Persistent   <- PipelineOutput
output = IO FilePath
persistent_fn
 | Bool
is_last_phase, PipelineOutput
SpecificFile <- PipelineOutput
output = case DynFlags -> Maybe FilePath
outputFile DynFlags
dflags of
                                           Just f :: FilePath
f -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f
                                           Nothing ->
                                               FilePath -> IO FilePath
forall a. FilePath -> a
panic "SpecificFile: No filename"
 | Bool
keep_this_output                      = IO FilePath
persistent_fn
 | Temporary lifetime :: TempFileLifetime
lifetime <- PipelineOutput
output          = DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
lifetime FilePath
suffix
 | Bool
otherwise                             = DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule
   FilePath
suffix
    where
          hcsuf :: FilePath
hcsuf      = DynFlags -> FilePath
hcSuf DynFlags
dflags
          odir :: Maybe FilePath
odir       = DynFlags -> Maybe FilePath
objectDir DynFlags
dflags
          osuf :: FilePath
osuf       = DynFlags -> FilePath
objectSuf DynFlags
dflags
          keep_hc :: Bool
keep_hc    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepHcFiles DynFlags
dflags
          keep_hscpp :: Bool
keep_hscpp = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepHscppFiles DynFlags
dflags
          keep_s :: Bool
keep_s     = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepSFiles DynFlags
dflags
          keep_bc :: Bool
keep_bc    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepLlvmFiles DynFlags
dflags

          myPhaseInputExt :: Phase -> FilePath
myPhaseInputExt HCc       = FilePath
hcsuf
          myPhaseInputExt MergeForeign = FilePath
osuf
          myPhaseInputExt StopLn    = FilePath
osuf
          myPhaseInputExt other :: Phase
other     = Phase -> FilePath
phaseInputExt Phase
other

          is_last_phase :: Bool
is_last_phase = Phase
next_phase Phase -> Phase -> Bool
`eqPhase` Phase
stop_phase

          -- sometimes, we keep output from intermediate stages
          keep_this_output :: Bool
keep_this_output =
               case Phase
next_phase of
                       As _    | Bool
keep_s     -> Bool
True
                       LlvmOpt | Bool
keep_bc    -> Bool
True
                       HCc     | Bool
keep_hc    -> Bool
True
                       HsPp _  | Bool
keep_hscpp -> Bool
True   -- See Trac #10869
                       _other :: Phase
_other               -> Bool
False

          suffix :: FilePath
suffix = Phase -> FilePath
myPhaseInputExt Phase
next_phase

          -- persistent object files get put in odir
          persistent_fn :: IO FilePath
persistent_fn
             | Phase
StopLn <- Phase
next_phase = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
odir_persistent
             | Bool
otherwise            = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
persistent

          persistent :: FilePath
persistent = FilePath
basename FilePath -> FilePath -> FilePath
<.> FilePath
suffix

          odir_persistent :: FilePath
odir_persistent
             | Just loc :: ModLocation
loc <- Maybe ModLocation
maybe_location = ModLocation -> FilePath
ml_obj_file ModLocation
loc
             | Just d :: FilePath
d <- Maybe FilePath
odir = FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
persistent
             | Bool
otherwise      = FilePath
persistent


-- | The fast LLVM Pipeline skips the mangler and assembler,
-- emitting object code directly from llc.
--
-- slow: opt -> llc -> .s -> mangler -> as -> .o
-- fast: opt -> llc -> .o
--
-- hidden flag: -ffast-llvm
--
-- if keep-s-files is specified, we need to go through
-- the slow pipeline (Kavon Farvardin requested this).
fastLlvmPipeline :: DynFlags -> Bool
fastLlvmPipeline :: DynFlags -> Bool
fastLlvmPipeline dflags :: DynFlags
dflags
  = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepSFiles DynFlags
dflags) Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FastLlvm DynFlags
dflags

-- | LLVM Options. These are flags to be passed to opt and llc, to ensure
-- consistency we list them in pairs, so that they form groups.
llvmOptions :: DynFlags
            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments
llvmOptions :: DynFlags -> [(FilePath, FilePath)]
llvmOptions dflags :: DynFlags
dflags =
       [("-enable-tbaa -tbaa",  "-enable-tbaa") | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LlvmTBAA DynFlags
dflags ]
    [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [("-relocation-model=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
rmodel
        ,"-relocation-model=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
rmodel) | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
rmodel)]
    [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [("-stack-alignment=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
align)
        ,"-stack-alignment=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
align)) | Int
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 ]
    [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [("", "-filetype=obj") | DynFlags -> Bool
fastLlvmPipeline DynFlags
dflags ]

    -- Additional llc flags
    [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [("", "-mcpu=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mcpu)   | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
mcpu)
                                 , Bool -> Bool
not ((FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf "-mcpu") (DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_lc)) ]
    [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [("", "-mattr=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
attrs) | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
attrs) ]

  where target :: FilePath
target = LLVM_TARGET
        Just (LlvmTarget _ mcpu :: FilePath
mcpu mattr :: [FilePath]
mattr) = FilePath -> [(FilePath, LlvmTarget)] -> Maybe LlvmTarget
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
target (DynFlags -> [(FilePath, LlvmTarget)]
llvmTargets DynFlags
dflags)

        -- Relocation models
        rmodel :: FilePath
rmodel | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PIC DynFlags
dflags        = "pic"
               | DynFlags -> Bool
positionIndependent DynFlags
dflags = "pic"
               | Way
WayDyn Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags  = "dynamic-no-pic"
               | Bool
otherwise                  = "static"

        align :: Int
        align :: Int
align = case Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
                  ArchX86_64 | DynFlags -> Bool
isAvxEnabled DynFlags
dflags -> 32
                  _                                -> 0

        attrs :: String
        attrs :: FilePath
attrs = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "," ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
mattr
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+sse42"   | DynFlags -> Bool
isSse4_2Enabled DynFlags
dflags   ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+sse2"    | DynFlags -> Bool
isSse2Enabled DynFlags
dflags     ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+sse"     | DynFlags -> Bool
isSseEnabled DynFlags
dflags      ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+avx512f" | DynFlags -> Bool
isAvx512fEnabled DynFlags
dflags  ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+avx2"    | DynFlags -> Bool
isAvx2Enabled DynFlags
dflags     ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+avx"     | DynFlags -> Bool
isAvxEnabled DynFlags
dflags      ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+avx512cd"| DynFlags -> Bool
isAvx512cdEnabled DynFlags
dflags ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+avx512er"| DynFlags -> Bool
isAvx512erEnabled DynFlags
dflags ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+avx512pf"| DynFlags -> Bool
isAvx512pfEnabled DynFlags
dflags ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+bmi"     | DynFlags -> Bool
isBmiEnabled DynFlags
dflags      ]
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["+bmi2"    | DynFlags -> Bool
isBmi2Enabled DynFlags
dflags     ]

-- -----------------------------------------------------------------------------
-- | Each phase in the pipeline returns the next phase to execute, and the
-- name of the file in which the output was placed.
--
-- We must do things dynamically this way, because we often don't know
-- what the rest of the phases will be until part-way through the
-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
-- of a source file can change the latter stages of the pipeline from
-- taking the LLVM route to using the native code generator.
--
runPhase :: PhasePlus   -- ^ Run this phase
         -> FilePath    -- ^ name of the input file
         -> DynFlags    -- ^ for convenience, we pass the current dflags in
         -> CompPipeline (PhasePlus,           -- next phase to run
                          FilePath)            -- output filename

        -- Invariant: the output filename always contains the output
        -- Interesting case: Hsc when there is no recompilation to do
        --                   Then the output filename is still a .o file


-------------------------------------------------------------------------------
-- Unlit phase

runPhase :: PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
runPhase (RealPhase (Unlit sf :: HscSource
sf)) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do
       FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename (HscSource -> Phase
Cpp HscSource
sf)

       let flags :: [Option]
flags = [ -- The -h option passes the file name for unlit to
                     -- put in a #line directive
                     FilePath -> Option
SysTools.Option     "-h"
                     -- See Note [Don't normalise input filenames].
                   , FilePath -> Option
SysTools.Option (FilePath -> Option) -> FilePath -> Option
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
escape FilePath
input_fn
                   , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
input_fn
                   , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
output_fn
                   ]

       IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
SysTools.runUnlit DynFlags
dflags [Option]
flags

       (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Cpp HscSource
sf), FilePath
output_fn)
  where
       -- escape the characters \, ", and ', but don't try to escape
       -- Unicode or anything else (so we don't use Util.charToC
       -- here).  If we get this wrong, then in
       -- Coverage.isGoodTickSrcSpan where we check that the filename in
       -- a SrcLoc is the same as the source filenaame, the two will
       -- look bogusly different. See test:
       -- libraries/hpc/tests/function/subdir/tough2.hs
       escape :: FilePath -> FilePath
escape ('\\':cs :: FilePath
cs) = '\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
escape FilePath
cs
       escape ('\"':cs :: FilePath
cs) = '\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'\"'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
escape FilePath
cs
       escape ('\'':cs :: FilePath
cs) = '\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:'\''Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
escape FilePath
cs
       escape (c :: Char
c:cs :: FilePath
cs)    = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
escape FilePath
cs
       escape []        = []

-------------------------------------------------------------------------------
-- Cpp phase : (a) gets OPTIONS out of file
--             (b) runs cpp if necessary

runPhase (RealPhase (Cpp sf :: HscSource
sf)) input_fn :: FilePath
input_fn dflags0 :: DynFlags
dflags0
  = do
       [Located FilePath]
src_opts <- IO [Located FilePath] -> CompPipeline [Located FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located FilePath] -> CompPipeline [Located FilePath])
-> IO [Located FilePath] -> CompPipeline [Located FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO [Located FilePath]
getOptionsFromFile DynFlags
dflags0 FilePath
input_fn
       (dflags1 :: DynFlags
dflags1, unhandled_flags :: [Located FilePath]
unhandled_flags, warns :: [Warn]
warns)
           <- IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located FilePath], [Warn])
 -> CompPipeline (DynFlags, [Located FilePath], [Warn]))
-> IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
src_opts
       DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags1
       IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Located FilePath] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located FilePath] -> m ()
checkProcessArgsResult DynFlags
dflags1 [Located FilePath]
unhandled_flags

       if Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.Cpp DynFlags
dflags1) then do
           -- we have to be careful to emit warnings only once.
           Bool -> CompPipeline () -> CompPipeline ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags1) (CompPipeline () -> CompPipeline ())
-> CompPipeline () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$
               IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags1 [Warn]
warns

           -- no need to preprocess CPP, just pass input file along
           -- to the next phase of the pipeline.
           (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
HsPp HscSource
sf), FilePath
input_fn)
        else do
            FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename (HscSource -> Phase
HsPp HscSource
sf)
            IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp DynFlags
dflags1 Bool
True{-raw-}
                           FilePath
input_fn FilePath
output_fn
            -- re-read the pragmas now that we've preprocessed the file
            -- See #2464,#3457
            [Located FilePath]
src_opts <- IO [Located FilePath] -> CompPipeline [Located FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located FilePath] -> CompPipeline [Located FilePath])
-> IO [Located FilePath] -> CompPipeline [Located FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO [Located FilePath]
getOptionsFromFile DynFlags
dflags0 FilePath
output_fn
            (dflags2 :: DynFlags
dflags2, unhandled_flags :: [Located FilePath]
unhandled_flags, warns :: [Warn]
warns)
                <- IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located FilePath], [Warn])
 -> CompPipeline (DynFlags, [Located FilePath], [Warn]))
-> IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
src_opts
            IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Located FilePath] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located FilePath] -> m ()
checkProcessArgsResult DynFlags
dflags2 [Located FilePath]
unhandled_flags
            Bool -> CompPipeline () -> CompPipeline ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags2) (CompPipeline () -> CompPipeline ())
-> CompPipeline () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$
                IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags2 [Warn]
warns
            -- the HsPp pass below will emit warnings

            DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags2

            (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
HsPp HscSource
sf), FilePath
output_fn)

-------------------------------------------------------------------------------
-- HsPp phase

runPhase (RealPhase (HsPp sf :: HscSource
sf)) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do
       if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags) then
           -- no need to preprocess, just pass input file along
           -- to the next phase of the pipeline.
          (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Hsc HscSource
sf), FilePath
input_fn)
        else do
            PipeEnv{FilePath
src_basename :: FilePath
src_basename :: PipeEnv -> FilePath
src_basename, FilePath
src_suffix :: FilePath
src_suffix :: PipeEnv -> FilePath
src_suffix} <- CompPipeline PipeEnv
getPipeEnv
            let orig_fn :: FilePath
orig_fn = FilePath
src_basename FilePath -> FilePath -> FilePath
<.> FilePath
src_suffix
            FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename (HscSource -> Phase
Hsc HscSource
sf)
            IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
SysTools.runPp DynFlags
dflags
                           ( [ FilePath -> Option
SysTools.Option     FilePath
orig_fn
                             , FilePath -> Option
SysTools.Option     FilePath
input_fn
                             , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
output_fn
                             ]
                           )

            -- re-read pragmas now that we've parsed the file (see #3674)
            [Located FilePath]
src_opts <- IO [Located FilePath] -> CompPipeline [Located FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located FilePath] -> CompPipeline [Located FilePath])
-> IO [Located FilePath] -> CompPipeline [Located FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO [Located FilePath]
getOptionsFromFile DynFlags
dflags FilePath
output_fn
            (dflags1 :: DynFlags
dflags1, unhandled_flags :: [Located FilePath]
unhandled_flags, warns :: [Warn]
warns)
                <- IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located FilePath], [Warn])
 -> CompPipeline (DynFlags, [Located FilePath], [Warn]))
-> IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags [Located FilePath]
src_opts
            DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags1
            IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Located FilePath] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located FilePath] -> m ()
checkProcessArgsResult DynFlags
dflags1 [Located FilePath]
unhandled_flags
            IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags1 [Warn]
warns

            (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Hsc HscSource
sf), FilePath
output_fn)

-----------------------------------------------------------------------------
-- Hsc phase

-- Compilation of a single module, in "legacy" mode (_not_ under
-- the direction of the compilation manager).
runPhase (RealPhase (Hsc src_flavour :: HscSource
src_flavour)) input_fn :: FilePath
input_fn dflags0 :: DynFlags
dflags0
 = do   -- normal Hsc mode, not mkdependHS

        PipeEnv{ stop_phase :: PipeEnv -> Phase
stop_phase=Phase
stop,
                 src_basename :: PipeEnv -> FilePath
src_basename=FilePath
basename,
                 src_suffix :: PipeEnv -> FilePath
src_suffix=FilePath
suff } <- CompPipeline PipeEnv
getPipeEnv

  -- we add the current directory (i.e. the directory in which
  -- the .hs files resides) to the include path, since this is
  -- what gcc does, and it's probably what you want.
        let current_dir :: FilePath
current_dir = FilePath -> FilePath
takeDirectory FilePath
basename
            new_includes :: IncludeSpecs
new_includes = IncludeSpecs -> [FilePath] -> IncludeSpecs
addQuoteInclude IncludeSpecs
paths [FilePath
current_dir]
            paths :: IncludeSpecs
paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags0
            dflags :: DynFlags
dflags = DynFlags
dflags0 { includePaths :: IncludeSpecs
includePaths = IncludeSpecs
new_includes }

        DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags

  -- gather the imports and module name
        (hspp_buf :: Maybe InputFileBuffer
hspp_buf,mod_name :: ModuleName
mod_name,imps :: [(Maybe FastString, Located ModuleName)]
imps,src_imps :: [(Maybe FastString, Located ModuleName)]
src_imps) <- IO
  (Maybe InputFileBuffer, ModuleName,
   [(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)])
-> CompPipeline
     (Maybe InputFileBuffer, ModuleName,
      [(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Maybe InputFileBuffer, ModuleName,
    [(Maybe FastString, Located ModuleName)],
    [(Maybe FastString, Located ModuleName)])
 -> CompPipeline
      (Maybe InputFileBuffer, ModuleName,
       [(Maybe FastString, Located ModuleName)],
       [(Maybe FastString, Located ModuleName)]))
-> IO
     (Maybe InputFileBuffer, ModuleName,
      [(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)])
-> CompPipeline
     (Maybe InputFileBuffer, ModuleName,
      [(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)])
forall a b. (a -> b) -> a -> b
$ do
          do
            InputFileBuffer
buf <- FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
input_fn
            Either
  ErrorMessages
  ([(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)], Located ModuleName)
eimps <- DynFlags
-> InputFileBuffer
-> FilePath
-> FilePath
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
getImports DynFlags
dflags InputFileBuffer
buf FilePath
input_fn (FilePath
basename FilePath -> FilePath -> FilePath
<.> FilePath
suff)
            case Either
  ErrorMessages
  ([(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)], Located ModuleName)
eimps of
              Left errs :: ErrorMessages
errs -> ErrorMessages
-> IO
     (Maybe InputFileBuffer, ModuleName,
      [(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)])
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
errs
              Right (src_imps :: [(Maybe FastString, Located ModuleName)]
src_imps,imps :: [(Maybe FastString, Located ModuleName)]
imps,L _ mod_name :: ModuleName
mod_name) -> (Maybe InputFileBuffer, ModuleName,
 [(Maybe FastString, Located ModuleName)],
 [(Maybe FastString, Located ModuleName)])
-> IO
     (Maybe InputFileBuffer, ModuleName,
      [(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)])
forall (m :: * -> *) a. Monad m => a -> m a
return
                  (InputFileBuffer -> Maybe InputFileBuffer
forall a. a -> Maybe a
Just InputFileBuffer
buf, ModuleName
mod_name, [(Maybe FastString, Located ModuleName)]
imps, [(Maybe FastString, Located ModuleName)]
src_imps)

  -- Take -o into account if present
  -- Very like -ohi, but we must *only* do this if we aren't linking
  -- (If we're linking then the -o applies to the linked thing, not to
  -- the object file for one module.)
  -- Note the nasty duplication with the same computation in compileFile above
        ModLocation
location <- HscSource -> ModuleName -> CompPipeline ModLocation
getLocation HscSource
src_flavour ModuleName
mod_name

        let o_file :: FilePath
o_file = ModLocation -> FilePath
ml_obj_file ModLocation
location -- The real object file
            hi_file :: FilePath
hi_file = ModLocation -> FilePath
ml_hi_file ModLocation
location
            hie_file :: FilePath
hie_file = ModLocation -> FilePath
ml_hie_file ModLocation
location
            dest_file :: FilePath
dest_file | DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags
                            = FilePath
hi_file
                      | Bool
otherwise
                            = FilePath
o_file

  -- Figure out if the source has changed, for recompilation avoidance.
  --
  -- Setting source_unchanged to True means that M.o (or M.hie) seems
  -- to be up to date wrt M.hs; so no need to recompile unless imports have
  -- changed (which the compiler itself figures out).
  -- Setting source_unchanged to False tells the compiler that M.o is out of
  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
        UTCTime
src_timestamp <- IO UTCTime -> CompPipeline UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> CompPipeline UTCTime)
-> IO UTCTime -> CompPipeline UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime (FilePath
basename FilePath -> FilePath -> FilePath
<.> FilePath
suff)

        SourceModified
source_unchanged <- IO SourceModified -> CompPipeline SourceModified
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SourceModified -> CompPipeline SourceModified)
-> IO SourceModified -> CompPipeline SourceModified
forall a b. (a -> b) -> a -> b
$
          if Bool -> Bool
not (Phase -> Bool
isStopLn Phase
stop)
                -- SourceModified unconditionally if
                --      (a) recompilation checker is off, or
                --      (b) we aren't going all the way to .o file (e.g. ghc -S)
             then SourceModified -> IO SourceModified
forall (m :: * -> *) a. Monad m => a -> m a
return SourceModified
SourceModified
                -- Otherwise look at file modification dates
             else do Bool
dest_file_mod <- FilePath -> UTCTime -> IO Bool
sourceModified FilePath
dest_file UTCTime
src_timestamp
                     Bool
hie_file_mod <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags
                                        then FilePath -> UTCTime -> IO Bool
sourceModified FilePath
hie_file
                                                            UTCTime
src_timestamp
                                        else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                     if Bool
dest_file_mod Bool -> Bool -> Bool
|| Bool
hie_file_mod
                        then SourceModified -> IO SourceModified
forall (m :: * -> *) a. Monad m => a -> m a
return SourceModified
SourceModified
                        else SourceModified -> IO SourceModified
forall (m :: * -> *) a. Monad m => a -> m a
return SourceModified
SourceUnmodified

        PipeState{hsc_env :: PipeState -> HscEnv
hsc_env=HscEnv
hsc_env'} <- CompPipeline PipeState
getPipeState

  -- Tell the finder cache about this module
        Module
mod <- IO Module -> CompPipeline Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> CompPipeline Module)
-> IO Module -> CompPipeline Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env' ModuleName
mod_name ModLocation
location

  -- Make the ModSummary to hand to hscMain
        let
            mod_summary :: ModSummary
mod_summary = ModSummary :: Module
-> HscSource
-> ModLocation
-> UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> Maybe HsParsedModule
-> FilePath
-> DynFlags
-> Maybe InputFileBuffer
-> ModSummary
ModSummary {  ms_mod :: Module
ms_mod       = Module
mod,
                                        ms_hsc_src :: HscSource
ms_hsc_src   = HscSource
src_flavour,
                                        ms_hspp_file :: FilePath
ms_hspp_file = FilePath
input_fn,
                                        ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags,
                                        ms_hspp_buf :: Maybe InputFileBuffer
ms_hspp_buf  = Maybe InputFileBuffer
hspp_buf,
                                        ms_location :: ModLocation
ms_location  = ModLocation
location,
                                        ms_hs_date :: UTCTime
ms_hs_date   = UTCTime
src_timestamp,
                                        ms_obj_date :: Maybe UTCTime
ms_obj_date  = Maybe UTCTime
forall a. Maybe a
Nothing,
                                        ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod   = Maybe HsParsedModule
forall a. Maybe a
Nothing,
                                        ms_iface_date :: Maybe UTCTime
ms_iface_date   = Maybe UTCTime
forall a. Maybe a
Nothing,
                                        ms_hie_date :: Maybe UTCTime
ms_hie_date     = Maybe UTCTime
forall a. Maybe a
Nothing,
                                        ms_textual_imps :: [(Maybe FastString, Located ModuleName)]
ms_textual_imps = [(Maybe FastString, Located ModuleName)]
imps,
                                        ms_srcimps :: [(Maybe FastString, Located ModuleName)]
ms_srcimps      = [(Maybe FastString, Located ModuleName)]
src_imps }

  -- run the compiler!
        let msg :: HscEnv -> p -> RecompileRequired -> p -> IO ()
msg hsc_env :: HscEnv
hsc_env _ what :: RecompileRequired
what _ = HscEnv -> RecompileRequired -> IO ()
oneShotMsg HscEnv
hsc_env RecompileRequired
what
        (result :: HscStatus
result, _) <- IO (HscStatus, HomeModInfo)
-> CompPipeline (HscStatus, HomeModInfo)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HscStatus, HomeModInfo)
 -> CompPipeline (HscStatus, HomeModInfo))
-> IO (HscStatus, HomeModInfo)
-> CompPipeline (HscStatus, HomeModInfo)
forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, HomeModInfo)
hscIncrementalCompile Bool
True Maybe TcGblEnv
forall a. Maybe a
Nothing (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
forall p p. HscEnv -> p -> RecompileRequired -> p -> IO ()
msg) HscEnv
hsc_env'
                            ModSummary
mod_summary SourceModified
source_unchanged Maybe ModIface
forall a. Maybe a
Nothing (1,1)

        (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscSource -> ModuleName -> HscStatus -> PhasePlus
HscOut HscSource
src_flavour ModuleName
mod_name HscStatus
result,
                FilePath -> FilePath
forall a. FilePath -> a
panic "HscOut doesn't have an input filename")

runPhase (HscOut src_flavour :: HscSource
src_flavour mod_name :: ModuleName
mod_name result :: HscStatus
result) _ dflags :: DynFlags
dflags = do
        ModLocation
location <- HscSource -> ModuleName -> CompPipeline ModLocation
getLocation HscSource
src_flavour ModuleName
mod_name
        ModLocation -> CompPipeline ()
setModLocation ModLocation
location

        let o_file :: FilePath
o_file = ModLocation -> FilePath
ml_obj_file ModLocation
location -- The real object file
            hsc_lang :: HscTarget
hsc_lang = DynFlags -> HscTarget
hscTarget DynFlags
dflags
            next_phase :: Phase
next_phase = DynFlags -> HscSource -> HscTarget -> Phase
hscPostBackendPhase DynFlags
dflags HscSource
src_flavour HscTarget
hsc_lang

        case HscStatus
result of
            HscNotGeneratingCode ->
                (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn,
                        FilePath -> FilePath
forall a. FilePath -> a
panic "No output filename from Hsc when no-code")
            HscUpToDate ->
                do IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO ()
touchObjectFile DynFlags
dflags FilePath
o_file
                   -- The .o file must have a later modification date
                   -- than the source file (else we wouldn't get Nothing)
                   -- but we touch it anyway, to keep 'make' happy (we think).
                   (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, FilePath
o_file)
            HscUpdateBoot ->
                do -- In the case of hs-boot files, generate a dummy .o-boot
                   -- stamp file for the benefit of Make
                   IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO ()
touchObjectFile DynFlags
dflags FilePath
o_file
                   (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, FilePath
o_file)
            HscUpdateSig ->
                do -- We need to create a REAL but empty .o file
                   -- because we are going to attempt to put it in a library
                   PipeState{hsc_env :: PipeState -> HscEnv
hsc_env=HscEnv
hsc_env'} <- CompPipeline PipeState
getPipeState
                   let input_fn :: FilePath
input_fn = FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust "runPhase" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location)
                       basename :: FilePath
basename = FilePath -> FilePath
dropExtension FilePath
input_fn
                   IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub DynFlags
dflags HscEnv
hsc_env' FilePath
basename ModLocation
location ModuleName
mod_name
                   (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, FilePath
o_file)
            HscRecomp cgguts :: CgGuts
cgguts mod_summary :: ModSummary
mod_summary
              -> do FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase

                    PipeState{hsc_env :: PipeState -> HscEnv
hsc_env=HscEnv
hsc_env'} <- CompPipeline PipeState
getPipeState

                    (outputFilename :: FilePath
outputFilename, mStub :: Maybe FilePath
mStub, foreign_files :: [(ForeignSrcLang, FilePath)]
foreign_files) <- IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
-> CompPipeline
     (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
 -> CompPipeline
      (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)]))
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
-> CompPipeline
     (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
forall a b. (a -> b) -> a -> b
$
                      HscEnv
-> CgGuts
-> ModSummary
-> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
hscGenHardCode HscEnv
hsc_env' CgGuts
cgguts ModSummary
mod_summary FilePath
output_fn
                    Maybe FilePath
stub_o <- IO (Maybe FilePath) -> CompPipeline (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((FilePath -> IO FilePath) -> Maybe FilePath -> IO (Maybe FilePath)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HscEnv -> FilePath -> IO FilePath
compileStub HscEnv
hsc_env') Maybe FilePath
mStub)
                    [FilePath]
foreign_os <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$
                      ((ForeignSrcLang, FilePath) -> IO FilePath)
-> [(ForeignSrcLang, FilePath)] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ForeignSrcLang -> FilePath -> IO FilePath)
-> (ForeignSrcLang, FilePath) -> IO FilePath
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign HscEnv
hsc_env')) [(ForeignSrcLang, FilePath)]
foreign_files
                    [FilePath] -> CompPipeline ()
setForeignOs ([FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] FilePath -> [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
stub_o [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
foreign_os)

                    (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
outputFilename)

-----------------------------------------------------------------------------
-- Cmm phase

runPhase (RealPhase CmmCpp) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do
       FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
Cmm
       IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp DynFlags
dflags Bool
False{-not raw-}
                      FilePath
input_fn FilePath
output_fn
       (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
Cmm, FilePath
output_fn)

runPhase (RealPhase Cmm) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do
        let hsc_lang :: HscTarget
hsc_lang = DynFlags -> HscTarget
hscTarget DynFlags
dflags

        let next_phase :: Phase
next_phase = DynFlags -> HscSource -> HscTarget -> Phase
hscPostBackendPhase DynFlags
dflags HscSource
HsSrcFile HscTarget
hsc_lang

        FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase

        PipeState{HscEnv
hsc_env :: HscEnv
hsc_env :: PipeState -> HscEnv
hsc_env} <- CompPipeline PipeState
getPipeState

        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> FilePath -> FilePath -> IO ()
hscCompileCmmFile HscEnv
hsc_env FilePath
input_fn FilePath
output_fn

        (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)

-----------------------------------------------------------------------------
-- Cc phase

runPhase (RealPhase cc_phase :: Phase
cc_phase) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
   | (Phase -> Bool) -> [Phase] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Phase
cc_phase Phase -> Phase -> Bool
`eqPhase`) [Phase
Cc, Phase
Ccxx, Phase
HCc, Phase
Cobjc, Phase
Cobjcxx]
   = do
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
            hcc :: Bool
hcc = Phase
cc_phase Phase -> Phase -> Bool
`eqPhase` Phase
HCc

        let cmdline_include_paths :: IncludeSpecs
cmdline_include_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags

        -- HC files have the dependent packages stamped into them
        [InstalledUnitId]
pkgs <- if Bool
hcc then IO [InstalledUnitId] -> CompPipeline [InstalledUnitId]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [InstalledUnitId] -> CompPipeline [InstalledUnitId])
-> IO [InstalledUnitId] -> CompPipeline [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [InstalledUnitId]
getHCFilePackages FilePath
input_fn else [InstalledUnitId] -> CompPipeline [InstalledUnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return []

        -- add package include paths even if we're just compiling .c
        -- files; this is the Value Add(TM) that using ghc instead of
        -- gcc gives you :)
        [FilePath]
pkg_include_dirs <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [InstalledUnitId] -> IO [FilePath]
getPackageIncludePath DynFlags
dflags [InstalledUnitId]
pkgs
        let include_paths_global :: [FilePath]
include_paths_global = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ x :: FilePath
x xs :: [FilePath]
xs -> ("-I" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
              (IncludeSpecs -> [FilePath]
includePathsGlobal IncludeSpecs
cmdline_include_paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_include_dirs)
        let include_paths_quote :: [FilePath]
include_paths_quote = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ x :: FilePath
x xs :: [FilePath]
xs -> ("-iquote" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
              (IncludeSpecs -> [FilePath]
includePathsQuote IncludeSpecs
cmdline_include_paths)
        let include_paths :: [FilePath]
include_paths = [FilePath]
include_paths_quote [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
include_paths_global

        -- pass -D or -optP to preprocessor when compiling foreign C files
        -- (#16737). Doing it in this way is simpler and also enable the C
        -- compiler to performs preprocessing and parsing in a single pass,
        -- but it may introduce inconsistency if a different pgm_P is specified.
        let more_preprocessor_opts :: [FilePath]
more_preprocessor_opts = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ ["-Xpreprocessor", FilePath
i]
              | Bool -> Bool
not Bool
hcc
              , FilePath
i <- DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_P
              ]

        let gcc_extra_viac_flags :: [FilePath]
gcc_extra_viac_flags = DynFlags -> [FilePath]
extraGccViaCFlags DynFlags
dflags
        let pic_c_flags :: [FilePath]
pic_c_flags = DynFlags -> [FilePath]
picCCOpts DynFlags
dflags

        let verbFlags :: [FilePath]
verbFlags = DynFlags -> [FilePath]
getVerbFlags DynFlags
dflags

        -- cc-options are not passed when compiling .hc files.  Our
        -- hc code doesn't not #include any header files anyway, so these
        -- options aren't necessary.
        [FilePath]
pkg_extra_cc_opts <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$
          if Bool
hcc
             then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
             else DynFlags -> [InstalledUnitId] -> IO [FilePath]
getPackageExtraCcOpts DynFlags
dflags [InstalledUnitId]
pkgs

        [FilePath]
framework_paths <-
            if Platform -> Bool
platformUsesFrameworks Platform
platform
            then do [FilePath]
pkgFrameworkPaths <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [InstalledUnitId] -> IO [FilePath]
getPackageFrameworkPath DynFlags
dflags [InstalledUnitId]
pkgs
                    let cmdlineFrameworkPaths :: [FilePath]
cmdlineFrameworkPaths = DynFlags -> [FilePath]
frameworkPaths DynFlags
dflags
                    [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> CompPipeline [FilePath])
-> [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ("-F"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
                                 ([FilePath]
cmdlineFrameworkPaths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkgFrameworkPaths)
            else [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []

        let cc_opt :: [FilePath]
cc_opt | DynFlags -> Int
optLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 = [ "-O2" ]
                   | DynFlags -> Int
optLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 1 = [ "-O" ]
                   | Bool
otherwise            = []

        -- Decide next phase
        let next_phase :: Phase
next_phase = Bool -> Phase
As Bool
False
        FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase

        let
          more_hcc_opts :: [FilePath]
more_hcc_opts =
                -- on x86 the floating point regs have greater precision
                -- than a double, which leads to unpredictable results.
                -- By default, we turn this off with -ffloat-store unless
                -- the user specified -fexcess-precision.
                (if Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchX86 Bool -> Bool -> Bool
&&
                    Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExcessPrecision DynFlags
dflags)
                        then [ "-ffloat-store" ]
                        else []) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++

                -- gcc's -fstrict-aliasing allows two accesses to memory
                -- to be considered non-aliasing if they have different types.
                -- This interacts badly with the C code we generate, which is
                -- very weakly typed, being derived from C--.
                ["-fno-strict-aliasing"]

        FilePath
ghcVersionH <- IO FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> CompPipeline FilePath)
-> IO FilePath -> CompPipeline FilePath
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO FilePath
getGhcVersionPathName DynFlags
dflags

        let gcc_lang_opt :: FilePath
gcc_lang_opt | Phase
cc_phase Phase -> Phase -> Bool
`eqPhase` Phase
Ccxx    = "c++"
                         | Phase
cc_phase Phase -> Phase -> Bool
`eqPhase` Phase
Cobjc   = "objective-c"
                         | Phase
cc_phase Phase -> Phase -> Bool
`eqPhase` Phase
Cobjcxx = "objective-c++"
                         | Bool
otherwise                  = "c"
        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
SysTools.runCc DynFlags
dflags (
                -- 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.
                        [ FilePath -> Option
SysTools.Option "-x", FilePath -> Option
SysTools.Option FilePath
gcc_lang_opt
                        , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
input_fn
                        , FilePath -> Option
SysTools.Option "-o"
                        , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
output_fn
                        ]
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option (
                          [FilePath]
pic_c_flags

                -- Stub files generated for foreign exports references the runIO_closure
                -- and runNonIO_closure symbols, which are defined in the base package.
                -- These symbols are imported into the stub.c file via RtsAPI.h, and the
                -- way we do the import depends on whether we're currently compiling
                -- the base package or not.
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 Bool -> Bool -> Bool
&&
                              DynFlags -> UnitId
thisPackage DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
baseUnitId
                                then [ "-DCOMPILING_BASE_PACKAGE" ]
                                else [])

        -- We only support SparcV9 and better because V8 lacks an atomic CAS
        -- instruction. Note that the user can still override this
        -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
        -- regardless of the ordering.
        --
        -- This is a temporary hack. See #2872, commit
        -- 5bd3072ac30216a505151601884ac88bf404c9f2
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchSPARC
                           then ["-mcpu=v9"]
                           else [])

                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if (Phase
cc_phase Phase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
/= Phase
Ccxx Bool -> Bool -> Bool
&& Phase
cc_phase Phase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
/= Phase
Cobjcxx)
                             then ["-Wimplicit"]
                             else [])

                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Bool
hcc
                             then [FilePath]
gcc_extra_viac_flags [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
more_hcc_opts
                             else [])
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
verbFlags
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ "-S" ]
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
cc_opt
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ "-include", FilePath
ghcVersionH ]
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
framework_paths
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
include_paths
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
more_preprocessor_opts
                       [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_extra_cc_opts
                       ))

        (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)

-----------------------------------------------------------------------------
-- Splitting phase

runPhase (RealPhase Splitter) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do  -- tmp_pfx is the prefix used for the split .s files

        FilePath
split_s_prefix <-
          IO FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> CompPipeline FilePath)
-> IO FilePath -> CompPipeline FilePath
forall a b. (a -> b) -> a -> b
$ DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule "split"
        let n_files_fn :: FilePath
n_files_fn = FilePath
split_s_prefix

        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
SysTools.runSplit DynFlags
dflags
                          [ FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
input_fn
                          , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
split_s_prefix
                          , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
n_files_fn
                          ]

        -- Save the number of split files for future references
        FilePath
s <- IO FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> CompPipeline FilePath)
-> IO FilePath -> CompPipeline FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
n_files_fn
        let n_files :: Int
n_files = FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
s :: Int
            dflags' :: DynFlags
dflags' = DynFlags
dflags { splitInfo :: Maybe (FilePath, Int)
splitInfo = (FilePath, Int) -> Maybe (FilePath, Int)
forall a. a -> Maybe a
Just (FilePath
split_s_prefix, Int
n_files) }

        DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags'

        -- Remember to delete all these files
        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean DynFlags
dflags' TempFileLifetime
TFL_CurrentModule ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$
                                 [ FilePath
split_s_prefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "__" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ".s"
                                 | Int
n <- [1..Int
n_files]]

        (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
SplitAs,
                "**splitter**") -- we don't use the filename in SplitAs

-----------------------------------------------------------------------------
-- As, SpitAs phase : Assembler

-- This is for calling the assembler on a regular assembly file (not split).
runPhase (RealPhase (As with_cpp :: Bool
with_cpp)) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do
        -- LLVM from version 3.0 onwards doesn't support the OS X system
        -- assembler, so we use clang as the assembler instead. (#5636)
        let whichAsProg :: CompPipeline (DynFlags -> [Option] -> IO ())
whichAsProg | DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscLlvm Bool -> Bool -> Bool
&&
                          Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
                        = (DynFlags -> [Option] -> IO ())
-> CompPipeline (DynFlags -> [Option] -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags -> [Option] -> IO ()
SysTools.runClang
                        | Bool
otherwise = (DynFlags -> [Option] -> IO ())
-> CompPipeline (DynFlags -> [Option] -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags -> [Option] -> IO ()
SysTools.runAs

        DynFlags -> [Option] -> IO ()
as_prog <- CompPipeline (DynFlags -> [Option] -> IO ())
whichAsProg
        let cmdline_include_paths :: IncludeSpecs
cmdline_include_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags
        let pic_c_flags :: [FilePath]
pic_c_flags = DynFlags -> [FilePath]
picCCOpts DynFlags
dflags

        Phase
next_phase <- CompPipeline Phase
maybeMergeForeign
        FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase

        -- we create directories for the object file, because it
        -- might be a hierarchical module.
        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
output_fn)

        CompilerInfo
ccInfo <- IO CompilerInfo -> CompPipeline CompilerInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CompilerInfo -> CompPipeline CompilerInfo)
-> IO CompilerInfo -> CompPipeline CompilerInfo
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO CompilerInfo
getCompilerInfo DynFlags
dflags
        let global_includes :: [Option]
global_includes = [ FilePath -> Option
SysTools.Option ("-I" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p)
                              | FilePath
p <- IncludeSpecs -> [FilePath]
includePathsGlobal IncludeSpecs
cmdline_include_paths ]
        let local_includes :: [Option]
local_includes = [ FilePath -> Option
SysTools.Option ("-iquote" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p)
                             | FilePath
p <- IncludeSpecs -> [FilePath]
includePathsQuote IncludeSpecs
cmdline_include_paths ]
        let runAssembler :: FilePath -> FilePath -> m ()
runAssembler inputFilename :: FilePath
inputFilename outputFilename :: FilePath
outputFilename
                = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
as_prog DynFlags
dflags
                       ([Option]
local_includes [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
global_includes
                       -- See Note [-fPIC for assembler]
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
pic_c_flags
                       -- See Note [Produce big objects on Windows]
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
SysTools.Option "-Wa,-mbig-obj"
                          | Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                          , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                          ]

        -- We only support SparcV9 and better because V8 lacks an atomic CAS
        -- instruction so we have to make sure that the assembler accepts the
        -- instruction set. Note that the user can still override this
        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
        -- regardless of the ordering.
        --
        -- This is a temporary hack.
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (if Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchSPARC
                           then [FilePath -> Option
SysTools.Option "-mcpu=v9"]
                           else [])
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (if (CompilerInfo -> Bool) -> [CompilerInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CompilerInfo
ccInfo CompilerInfo -> CompilerInfo -> Bool
forall a. Eq a => a -> a -> Bool
==) [CompilerInfo
Clang, CompilerInfo
AppleClang, CompilerInfo
AppleClang51]
                            then [FilePath -> Option
SysTools.Option "-Qunused-arguments"]
                            else [])
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
SysTools.Option "-x"
                          , if Bool
with_cpp
                              then FilePath -> Option
SysTools.Option "assembler-with-cpp"
                              else FilePath -> Option
SysTools.Option "assembler"
                          , FilePath -> Option
SysTools.Option "-c"
                          , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
inputFilename
                          , FilePath -> Option
SysTools.Option "-o"
                          , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
outputFilename
                          ])

        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 4 (FilePath -> SDoc
text "Running the assembler")
        FilePath -> FilePath -> CompPipeline ()
forall (m :: * -> *). MonadIO m => FilePath -> FilePath -> m ()
runAssembler FilePath
input_fn FilePath
output_fn
        (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)


-- This is for calling the assembler on a split assembly file (so a collection
-- of assembly files)
runPhase (RealPhase SplitAs) _input_fn :: FilePath
_input_fn dflags :: DynFlags
dflags
  = do
        -- we'll handle the stub_o file in this phase, so don't MergeForeign,
        -- just jump straight to StopLn afterwards.
        let next_phase :: Phase
next_phase = Phase
StopLn
        FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase

        let base_o :: FilePath
base_o = FilePath -> FilePath
dropExtension FilePath
output_fn
            osuf :: FilePath
osuf = DynFlags -> FilePath
objectSuf DynFlags
dflags
            split_odir :: FilePath
split_odir  = FilePath
base_o FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
osuf FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "_split"

        let pic_c_flags :: [FilePath]
pic_c_flags = DynFlags -> [FilePath]
picCCOpts DynFlags
dflags

        -- this also creates the hierarchy
        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
split_odir

        -- remove M_split/ *.o, because we're going to archive M_split/ *.o
        -- later and we don't want to pick up any old objects.
        [FilePath]
fs <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
getDirectoryContents FilePath
split_odir
        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
removeFile ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$
                (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
split_odir FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath
osuf FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [FilePath]
fs

        let (split_s_prefix :: FilePath
split_s_prefix, n :: Int
n) = case DynFlags -> Maybe (FilePath, Int)
splitInfo DynFlags
dflags of
                                  Nothing -> FilePath -> (FilePath, Int)
forall a. FilePath -> a
panic "No split info"
                                  Just x :: (FilePath, Int)
x -> (FilePath, Int)
x

        let split_s :: a -> FilePath
split_s   n :: a
n = FilePath
split_s_prefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "__" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
n FilePath -> FilePath -> FilePath
<.> "s"

            split_obj :: Int -> FilePath
            split_obj :: Int -> FilePath
split_obj n :: Int
n = FilePath
split_odir FilePath -> FilePath -> FilePath
</>
                          FilePath -> FilePath
takeFileName FilePath
base_o FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "__" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
<.> FilePath
osuf

        let assemble_file :: Int -> IO ()
assemble_file n :: Int
n
              = DynFlags -> [Option] -> IO ()
SysTools.runAs DynFlags
dflags (

        -- We only support SparcV9 and better because V8 lacks an atomic CAS
        -- instruction so we have to make sure that the assembler accepts the
        -- instruction set. Note that the user can still override this
        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
        -- regardless of the ordering.
        --
        -- This is a temporary hack.
                          (if Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchSPARC
                           then [FilePath -> Option
SysTools.Option "-mcpu=v9"]
                           else []) [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++

                          -- See Note [-fPIC for assembler]
                          (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
pic_c_flags [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++

                          [ FilePath -> Option
SysTools.Option "-c"
                          , FilePath -> Option
SysTools.Option "-o"
                          , FilePath -> FilePath -> Option
SysTools.FileOption "" (Int -> FilePath
split_obj Int
n)
                          , FilePath -> FilePath -> Option
SysTools.FileOption "" (Int -> FilePath
forall a. Show a => a -> FilePath
split_s Int
n)
                          ])

        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
assemble_file [1..Int
n]

        -- Note [pipeline-split-init]
        -- If we have a stub file -- which will be part of foreign_os --
        --  it may contain constructor
        -- functions for initialisation of this module.  We can't
        -- simply leave the stub as a separate object file, because it
        -- will never be linked in: nothing refers to it.  We need to
        -- ensure that if we ever refer to the data in this module
        -- that needs initialisation, then we also pull in the
        -- initialisation routine.
        --
        -- To that end, we make a DANGEROUS ASSUMPTION here: the data
        -- that needs to be initialised is all in the FIRST split
        -- object.  See Note [codegen-split-init].
        --
        -- We also merge in all the foreign objects since we're at it.

        PipeState{[FilePath]
foreign_os :: [FilePath]
foreign_os :: PipeState -> [FilePath]
foreign_os} <- CompPipeline PipeState
getPipeState
        if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
foreign_os
          then () -> CompPipeline ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ do
             FilePath
tmp_split_1 <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
osuf
             let split_1 :: FilePath
split_1 = Int -> FilePath
split_obj 1
             FilePath -> FilePath -> IO ()
copyFile FilePath
split_1 FilePath
tmp_split_1
             FilePath -> IO ()
removeFile FilePath
split_1
             DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles DynFlags
dflags (FilePath
tmp_split_1 FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
foreign_os) FilePath
split_1

        -- join them into a single .o file
        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles DynFlags
dflags ((Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FilePath
split_obj [1..Int
n]) FilePath
output_fn

        (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)

-----------------------------------------------------------------------------
-- LlvmOpt phase
runPhase (RealPhase LlvmOpt) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do
    FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
LlvmLlc

    IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
SysTools.runLlvmOpt DynFlags
dflags
               (   [Option]
optFlag
                [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
defaultOptions [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++
                [ FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
input_fn
                , FilePath -> Option
SysTools.Option "-o"
                , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
output_fn]
                )

    (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
LlvmLlc, FilePath
output_fn)
  where
        -- we always (unless -optlo specified) run Opt since we rely on it to
        -- fix up some pretty big deficiencies in the code we generate
        optIdx :: Int
optIdx = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int
optLevel DynFlags
dflags  -- ensure we're in [0,2]
        llvmOpts :: FilePath
llvmOpts = case Int -> [(Int, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
optIdx ([(Int, FilePath)] -> Maybe FilePath)
-> [(Int, FilePath)] -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ DynFlags -> [(Int, FilePath)]
llvmPasses DynFlags
dflags of
                    Just passes :: FilePath
passes -> FilePath
passes
                    Nothing -> FilePath -> FilePath
forall a. FilePath -> a
panic ("runPhase LlvmOpt: llvm-passes file "
                                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "is missing passes for level "
                                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
optIdx)

        -- don't specify anything if user has specified commands. We do this
        -- for opt but not llc since opt is very specifically for optimisation
        -- passes only, so if the user is passing us extra options we assume
        -- they know what they are doing and don't get in the way.
        optFlag :: [Option]
optFlag = if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_lo)
                  then (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
words FilePath
llvmOpts
                  else []

        defaultOptions :: [Option]
defaultOptions = (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option ([FilePath] -> [Option])
-> (([FilePath], [FilePath]) -> [FilePath])
-> ([FilePath], [FilePath])
-> [Option]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath])
-> (([FilePath], [FilePath]) -> [[FilePath]])
-> ([FilePath], [FilePath])
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
words ([FilePath] -> [[FilePath]])
-> (([FilePath], [FilePath]) -> [FilePath])
-> ([FilePath], [FilePath])
-> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath], [FilePath]) -> [FilePath]
forall a b. (a, b) -> a
fst
                       (([FilePath], [FilePath]) -> [Option])
-> ([FilePath], [FilePath]) -> [Option]
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> ([FilePath], [FilePath])
forall a b. [(a, b)] -> ([a], [b])
unzip (DynFlags -> [(FilePath, FilePath)]
llvmOptions DynFlags
dflags)

-----------------------------------------------------------------------------
-- LlvmLlc phase

runPhase (RealPhase LlvmLlc) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do
    Phase
next_phase <- if DynFlags -> Bool
fastLlvmPipeline DynFlags
dflags
                  then CompPipeline Phase
maybeMergeForeign
                  -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
                  else case GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoLlvmMangler DynFlags
dflags of
                         False                            -> Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return Phase
LlvmMangle
                         True | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags -> Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return Phase
Splitter
                         True                             -> Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Phase
As Bool
False)

    FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase

    IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
SysTools.runLlvmLlc DynFlags
dflags
                (  [Option]
optFlag
                [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
defaultOptions
                [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
input_fn
                   , FilePath -> Option
SysTools.Option "-o"
                   , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
output_fn
                   ]
                )

    (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)
  where
    -- Note [Clamping of llc optimizations]
    --
    -- See #13724
    --
    -- we clamp the llc optimization between [1,2]. This is because passing -O0
    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
    --
    --   Error while trying to spill R1 from class GPR: Cannot scavenge register
    --   without an emergency spill slot!
    --
    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
    --
    --
    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
    --   rts/HeapStackCheck.cmm
    --
    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358
    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876
    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
    -- 13 llc                      0x000000010195bf0b main + 491
    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1
    -- Stack dump:
    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
    --
    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
    --
    llvmOpts :: FilePath
llvmOpts = case DynFlags -> Int
optLevel DynFlags
dflags of
      0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
      1 -> "-O1"
      _ -> "-O2"

    optFlag :: [Option]
optFlag = if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_lc)
              then (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
words FilePath
llvmOpts
              else []

    defaultOptions :: [Option]
defaultOptions = (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option ([FilePath] -> [Option])
-> (([FilePath], [FilePath]) -> [FilePath])
-> ([FilePath], [FilePath])
-> [Option]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath])
-> (([FilePath], [FilePath]) -> [[FilePath]])
-> ([FilePath], [FilePath])
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
words ([FilePath] -> [[FilePath]])
-> (([FilePath], [FilePath]) -> [FilePath])
-> ([FilePath], [FilePath])
-> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath], [FilePath]) -> [FilePath]
forall a b. (a, b) -> b
snd
                   (([FilePath], [FilePath]) -> [Option])
-> ([FilePath], [FilePath]) -> [Option]
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> ([FilePath], [FilePath])
forall a b. [(a, b)] -> ([a], [b])
unzip (DynFlags -> [(FilePath, FilePath)]
llvmOptions DynFlags
dflags)


-----------------------------------------------------------------------------
-- LlvmMangle phase

runPhase (RealPhase LlvmMangle) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
  = do
      let next_phase :: Phase
next_phase = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags then Phase
Splitter else Bool -> Phase
As Bool
False
      FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase
      IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> FilePath -> IO ()
llvmFixupAsm DynFlags
dflags FilePath
input_fn FilePath
output_fn
      (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)

-----------------------------------------------------------------------------
-- merge in stub objects

runPhase (RealPhase MergeForeign) input_fn :: FilePath
input_fn dflags :: DynFlags
dflags
 = do
     PipeState{[FilePath]
foreign_os :: [FilePath]
foreign_os :: PipeState -> [FilePath]
foreign_os} <- CompPipeline PipeState
getPipeState
     FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
StopLn
     IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
output_fn)
     if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
foreign_os
       then FilePath -> CompPipeline (PhasePlus, FilePath)
forall a. FilePath -> a
panic "runPhase(MergeForeign): no foreign objects"
       else do
         IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles DynFlags
dflags (FilePath
input_fn FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
foreign_os) FilePath
output_fn
         (PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, FilePath
output_fn)

-- warning suppression
runPhase (RealPhase other :: Phase
other) _input_fn :: FilePath
_input_fn _dflags :: DynFlags
_dflags =
   FilePath -> CompPipeline (PhasePlus, FilePath)
forall a. FilePath -> a
panic ("runPhase: don't know how to run phase " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Phase -> FilePath
forall a. Show a => a -> FilePath
show Phase
other)

maybeMergeForeign :: CompPipeline Phase
maybeMergeForeign :: CompPipeline Phase
maybeMergeForeign
 = do
     PipeState{[FilePath]
foreign_os :: [FilePath]
foreign_os :: PipeState -> [FilePath]
foreign_os} <- CompPipeline PipeState
getPipeState
     if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
foreign_os then Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return Phase
StopLn else Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return Phase
MergeForeign

getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
getLocation src_flavour :: HscSource
src_flavour mod_name :: ModuleName
mod_name = do
    DynFlags
dflags <- CompPipeline DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    PipeEnv{ src_basename :: PipeEnv -> FilePath
src_basename=FilePath
basename,
             src_suffix :: PipeEnv -> FilePath
src_suffix=FilePath
suff } <- CompPipeline PipeEnv
getPipeEnv
    PipeState { maybe_loc :: PipeState -> Maybe ModLocation
maybe_loc=Maybe ModLocation
maybe_loc} <- CompPipeline PipeState
getPipeState
    case Maybe ModLocation
maybe_loc of
        -- Build a ModLocation to pass to hscMain.
        -- The source filename is rather irrelevant by now, but it's used
        -- by hscMain for messages.  hscMain also needs
        -- the .hi and .o filenames. If we already have a ModLocation
        -- then simply update the extensions of the interface and object
        -- files to match the DynFlags, otherwise use the logic in Finder.
      Just l :: ModLocation
l -> ModLocation -> CompPipeline ModLocation
forall (m :: * -> *) a. Monad m => a -> m a
return (ModLocation -> CompPipeline ModLocation)
-> ModLocation -> CompPipeline ModLocation
forall a b. (a -> b) -> a -> b
$ ModLocation
l
        { ml_hs_file :: Maybe FilePath
ml_hs_file = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
basename FilePath -> FilePath -> FilePath
<.> FilePath
suff
        , ml_hi_file :: FilePath
ml_hi_file = ModLocation -> FilePath
ml_hi_file ModLocation
l FilePath -> FilePath -> FilePath
-<.> DynFlags -> FilePath
hiSuf DynFlags
dflags
        , ml_obj_file :: FilePath
ml_obj_file = ModLocation -> FilePath
ml_obj_file ModLocation
l FilePath -> FilePath -> FilePath
-<.> DynFlags -> FilePath
objectSuf DynFlags
dflags
        }
      _ -> do
        ModLocation
location1 <- IO ModLocation -> CompPipeline ModLocation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModLocation -> CompPipeline ModLocation)
-> IO ModLocation -> CompPipeline ModLocation
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FilePath -> FilePath -> IO ModLocation
mkHomeModLocation2 DynFlags
dflags ModuleName
mod_name FilePath
basename FilePath
suff

        -- Boot-ify it if necessary
        let location2 :: ModLocation
location2
              | HscSource
HsBootFile <- HscSource
src_flavour = ModLocation -> ModLocation
addBootSuffixLocnOut ModLocation
location1
              | Bool
otherwise                 = ModLocation
location1


        -- Take -ohi into account if present
        -- This can't be done in mkHomeModuleLocation because
        -- it only applies to the module being compiles
        let ohi :: Maybe FilePath
ohi = DynFlags -> Maybe FilePath
outputHi DynFlags
dflags
            location3 :: ModLocation
location3 | Just fn :: FilePath
fn <- Maybe FilePath
ohi = ModLocation
location2{ ml_hi_file :: FilePath
ml_hi_file = FilePath
fn }
                      | Bool
otherwise      = ModLocation
location2

        -- Take -o into account if present
        -- Very like -ohi, but we must *only* do this if we aren't linking
        -- (If we're linking then the -o applies to the linked thing, not to
        -- the object file for one module.)
        -- Note the nasty duplication with the same computation in compileFile
        -- above
        let expl_o_file :: Maybe FilePath
expl_o_file = DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
            location4 :: ModLocation
location4 | Just ofile :: FilePath
ofile <- Maybe FilePath
expl_o_file
                      , GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
                      = ModLocation
location3 { ml_obj_file :: FilePath
ml_obj_file = FilePath
ofile }
                      | Bool
otherwise = ModLocation
location3
        ModLocation -> CompPipeline ModLocation
forall (m :: * -> *) a. Monad m => a -> m a
return ModLocation
location4

-----------------------------------------------------------------------------
-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file

getHCFilePackages :: FilePath -> IO [InstalledUnitId]
getHCFilePackages :: FilePath -> IO [InstalledUnitId]
getHCFilePackages filename :: FilePath
filename =
  IO Handle
-> (Handle -> IO ())
-> (Handle -> IO [InstalledUnitId])
-> IO [InstalledUnitId]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket (FilePath -> IOMode -> IO Handle
openFile FilePath
filename IOMode
ReadMode) Handle -> IO ()
hClose ((Handle -> IO [InstalledUnitId]) -> IO [InstalledUnitId])
-> (Handle -> IO [InstalledUnitId]) -> IO [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
    FilePath
l <- Handle -> IO FilePath
hGetLine Handle
h
    case FilePath
l of
      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest :: FilePath
rest ->
          [InstalledUnitId] -> IO [InstalledUnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> InstalledUnitId) -> [FilePath] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> InstalledUnitId
stringToInstalledUnitId (FilePath -> [FilePath]
words FilePath
rest))
      _other :: FilePath
_other ->
          [InstalledUnitId] -> IO [InstalledUnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-----------------------------------------------------------------------------
-- Static linking, of .o files

-- The list of packages passed to link is the list of packages on
-- which this program depends, as discovered by the compilation
-- manager.  It is combined with the list of packages that the user
-- specifies on the command line with -package flags.
--
-- In one-shot linking mode, we can't discover the package
-- dependencies (because we haven't actually done any compilation or
-- read any interface files), so the user must explicitly specify all
-- the packages.

{-
Note [-Xlinker -rpath vs -Wl,-rpath]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

-Wl takes a comma-separated list of options which in the case of
-Wl,-rpath -Wl,some,path,with,commas parses the path with commas
as separate options.
Buck, the build system, produces paths with commas in them.

-Xlinker doesn't have this disadvantage and as far as I can tell
it is supported by both gcc and clang. Anecdotally nvcc supports
-Xlinker, but not -Wl.
-}

linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary = Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary' Bool
False

linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkBinary' staticLink :: Bool
staticLink dflags :: DynFlags
dflags o_files :: [FilePath]
o_files dep_packages :: [InstalledUnitId]
dep_packages = do
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        mySettings :: Settings
mySettings = DynFlags -> Settings
settings DynFlags
dflags
        verbFlags :: [FilePath]
verbFlags = DynFlags -> [FilePath]
getVerbFlags DynFlags
dflags
        output_fn :: FilePath
output_fn = Bool -> DynFlags -> FilePath
exeFileName Bool
staticLink DynFlags
dflags

    -- get the full list of packages to link with, by combining the
    -- explicit packages with the auto packages and all of their
    -- dependencies, and eliminating duplicates.

    FilePath
full_output_fn <- if FilePath -> Bool
isAbsolute FilePath
output_fn
                      then FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
output_fn
                      else do FilePath
d <- IO FilePath
getCurrentDirectory
                              FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
normalise (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
output_fn)
    [FilePath]
pkg_lib_paths <- DynFlags -> [InstalledUnitId] -> IO [FilePath]
getPackageLibraryPath DynFlags
dflags [InstalledUnitId]
dep_packages
    let pkg_lib_path_opts :: [FilePath]
pkg_lib_path_opts = (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> [FilePath]
get_pkg_lib_path_opts [FilePath]
pkg_lib_paths
        get_pkg_lib_path_opts :: FilePath -> [FilePath]
get_pkg_lib_path_opts l :: FilePath
l
         | OS -> Bool
osElfTarget (Platform -> OS
platformOS Platform
platform) Bool -> Bool -> Bool
&&
           DynFlags -> DynLibLoader
dynLibLoader DynFlags
dflags DynLibLoader -> DynLibLoader -> Bool
forall a. Eq a => a -> a -> Bool
== DynLibLoader
SystemDependent Bool -> Bool -> Bool
&&
           Way
WayDyn Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags
            = let libpath :: FilePath
libpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
                            then "$ORIGIN" FilePath -> FilePath -> FilePath
</>
                                 (FilePath
l FilePath -> FilePath -> FilePath
`makeRelativeTo` FilePath
full_output_fn)
                            else FilePath
l
                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]
                  rpath :: [FilePath]
rpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RPath DynFlags
dflags
                          then ["-Xlinker", "-rpath", "-Xlinker", FilePath
libpath]
                          else []
                  -- Solaris 11's linker does not support -rpath-link option. It silently
                  -- ignores it and then complains about next option which is -l<some
                  -- dir> as being a directory and not expected object file, E.g
                  -- ld: elf error: file
                  -- /tmp/ghc-src/libraries/base/dist-install/build:
                  -- elf_begin: I/O error: region read: Is a directory
                  rpathlink :: [FilePath]
rpathlink = if (Platform -> OS
platformOS Platform
platform) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSSolaris2
                              then []
                              else ["-Xlinker", "-rpath-link", "-Xlinker", FilePath
l]
              in ["-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
rpathlink [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
rpath
         | OS -> Bool
osMachOTarget (Platform -> OS
platformOS Platform
platform) Bool -> Bool -> Bool
&&
           DynFlags -> DynLibLoader
dynLibLoader DynFlags
dflags DynLibLoader -> DynLibLoader -> Bool
forall a. Eq a => a -> a -> Bool
== DynLibLoader
SystemDependent Bool -> Bool -> Bool
&&
           Way
WayDyn Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags Bool -> Bool -> Bool
&&
           GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RPath DynFlags
dflags
            = let libpath :: FilePath
libpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
                            then "@loader_path" FilePath -> FilePath -> FilePath
</>
                                 (FilePath
l FilePath -> FilePath -> FilePath
`makeRelativeTo` FilePath
full_output_fn)
                            else FilePath
l
              in ["-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ["-Xlinker", "-rpath", "-Xlinker", FilePath
libpath]
         | Bool
otherwise = ["-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l]

    [FilePath]
pkg_lib_path_opts <-
      if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SingleLibFolder DynFlags
dflags
      then do
        [(FilePath, FilePath)]
libs <- DynFlags -> [InstalledUnitId] -> IO [(FilePath, FilePath)]
getLibs DynFlags
dflags [InstalledUnitId]
dep_packages
        FilePath
tmpDir <- DynFlags -> IO FilePath
newTempDir DynFlags
dflags
        [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ FilePath -> FilePath -> IO ()
copyFile FilePath
lib (FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
basename)
                  | (lib :: FilePath
lib, basename :: FilePath
basename) <- [(FilePath, FilePath)]
libs]
        [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [ "-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tmpDir ]
      else [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath]
pkg_lib_path_opts

    let
      dead_strip :: [FilePath]
dead_strip
        | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags = []
        | Bool
otherwise = if OS -> Bool
osSubsectionsViaSymbols (Platform -> OS
platformOS Platform
platform)
                        then ["-Wl,-dead_strip"]
                        else []
    let lib_paths :: [FilePath]
lib_paths = DynFlags -> [FilePath]
libraryPaths DynFlags
dflags
    let lib_path_opts :: [FilePath]
lib_path_opts = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ("-L"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
lib_paths

    FilePath
extraLinkObj <- DynFlags -> IO FilePath
mkExtraObjToLinkIntoBinary DynFlags
dflags
    [FilePath]
noteLinkObjs <- DynFlags -> [InstalledUnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary DynFlags
dflags [InstalledUnitId]
dep_packages

    let
      (pre_hs_libs :: [FilePath]
pre_hs_libs, post_hs_libs :: [FilePath]
post_hs_libs)
        | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags
        = if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
            then (["-Wl,-all_load"], [])
              -- OS X does not have a flag to turn off -all_load
            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
        | Bool
otherwise
        = ([],[])

    [FilePath]
pkg_link_opts <- do
        (package_hs_libs :: [FilePath]
package_hs_libs, extra_libs :: [FilePath]
extra_libs, other_flags :: [FilePath]
other_flags) <- DynFlags
-> [InstalledUnitId] -> IO ([FilePath], [FilePath], [FilePath])
getPackageLinkOpts DynFlags
dflags [InstalledUnitId]
dep_packages
        [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ if Bool
staticLink
            then [FilePath]
package_hs_libs -- If building an executable really means making a static
                                 -- library (e.g. iOS), then we only keep the -l options for
                                 -- HS packages, because libtool doesn't accept other options.
                                 -- In the case of iOS these need to be added by hand to the
                                 -- final link in Xcode.
            else [FilePath]
other_flags [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
dead_strip
                  [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pre_hs_libs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
package_hs_libs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
post_hs_libs
                  [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_libs
                 -- -Wl,-u,<sym> contained in other_flags
                 -- needs to be put before -l<package>,
                 -- otherwise Solaris linker fails linking
                 -- a binary with unresolved symbols in RTS
                 -- which are defined in base package
                 -- the reason for this is a note in ld(1) about
                 -- '-u' option: "The placement of this option
                 -- on the command line is significant.
                 -- This option must be placed before the library
                 -- that defines the symbol."

    -- frameworks
    [FilePath]
pkg_framework_opts <- DynFlags -> Platform -> [InstalledUnitId] -> IO [FilePath]
getPkgFrameworkOpts DynFlags
dflags Platform
platform [InstalledUnitId]
dep_packages
    let framework_opts :: [FilePath]
framework_opts = DynFlags -> Platform -> [FilePath]
getFrameworkOpts DynFlags
dflags Platform
platform

        -- probably _stub.o files
    let extra_ld_inputs :: [Option]
extra_ld_inputs = DynFlags -> [Option]
ldInputs DynFlags
dflags

    -- Here are some libs that need to be linked at the *end* of
    -- the command line, because they contain symbols that are referred to
    -- by the RTS.  We can't therefore use the ordinary way opts for these.
    let debug_opts :: [a]
debug_opts | Way
WayDebug Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags = [
#if defined(HAVE_LIBBFD)
                        "-lbfd", "-liberty"
#endif
                         ]
                   | Bool
otherwise                   = []

        thread_opts :: [FilePath]
thread_opts | Way
WayThreaded Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags = [
#if NEED_PTHREAD_LIB
                        "-lpthread"
#endif
                        ]
                    | Bool
otherwise                      = []

    [FilePath]
rc_objs <- DynFlags -> FilePath -> IO [FilePath]
maybeCreateManifest DynFlags
dflags FilePath
output_fn

    let link :: DynFlags -> [Option] -> IO ()
link = if Bool
staticLink
                   then DynFlags -> [Option] -> IO ()
SysTools.runLibtool
                   else DynFlags -> [Option] -> IO ()
SysTools.runLink
    DynFlags -> [Option] -> IO ()
link DynFlags
dflags (
                       (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
verbFlags
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
SysTools.Option "-o"
                         , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
output_fn
                         ]
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
libmLinkOpts
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option (
                         []

                      -- See Note [No PIE when linking]
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [FilePath]
picCCOpts DynFlags
dflags

                      -- Permit the linker to auto link _symbol to _imp_symbol.
                      -- This lets us link against DLLs without needing an "import library".
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                          then ["-Wl,--enable-auto-import"]
                          else [])

                      -- '-no_compact_unwind'
                      -- C++/Objective-C exceptions cannot use optimised
                      -- stack unwinding code. The optimised form is the
                      -- default in Xcode 4 on at least x86_64, and
                      -- without this flag we're also seeing warnings
                      -- like
                      --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
                      -- on x86.
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Settings -> Bool
sLdSupportsCompactUnwind Settings
mySettings Bool -> Bool -> Bool
&&
                             Bool -> Bool
not Bool
staticLink Bool -> Bool -> Bool
&&
                             (Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin) Bool -> Bool -> Bool
&&
                             case Platform -> Arch
platformArch Platform
platform of
                               ArchX86 -> Bool
True
                               ArchX86_64 -> Bool
True
                               ArchARM {} -> Bool
True
                               ArchARM64  -> Bool
True
                               _ -> Bool
False
                          then ["-Wl,-no_compact_unwind"]
                          else [])

                      -- '-Wl,-read_only_relocs,suppress'
                      -- ld gives loads of warnings like:
                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
                      -- when linking any program. We're not sure
                      -- whether this is something we ought to fix, but
                      -- for now this flags silences them.
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS   Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin Bool -> Bool -> Bool
&&
                             Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchX86 Bool -> Bool -> Bool
&&
                             Bool -> Bool
not Bool
staticLink
                          then ["-Wl,-read_only_relocs,suppress"]
                          else [])

                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Settings -> Bool
sLdIsGnuLd Settings
mySettings Bool -> Bool -> Bool
&&
                             Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags)
                          then ["-Wl,--gc-sections"]
                          else [])

                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
o_files
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
lib_path_opts)
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
extra_ld_inputs
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option (
                         [FilePath]
rc_objs
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
framework_opts
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_lib_path_opts
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ FilePath
extraLinkObjFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
noteLinkObjs
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_link_opts
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_framework_opts
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
forall a. [a]
debug_opts
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
thread_opts
                      [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
                          then [ "-Wl,-dead_strip_dylibs" ]
                          else [])
                    ))

exeFileName :: Bool -> DynFlags -> FilePath
exeFileName :: Bool -> DynFlags -> FilePath
exeFileName staticLink :: Bool
staticLink dflags :: DynFlags
dflags
  | Just s :: FilePath
s <- DynFlags -> Maybe FilePath
outputFile DynFlags
dflags =
      case Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
          OSMinGW32 -> FilePath
s FilePath -> FilePath -> FilePath
<?.> "exe"
          _         -> if Bool
staticLink
                         then FilePath
s FilePath -> FilePath -> FilePath
<?.> "a"
                         else FilePath
s
  | Bool
otherwise =
      if Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
      then "main.exe"
      else if Bool
staticLink
           then "liba.a"
           else "a.out"
 where s :: FilePath
s <?.> :: FilePath -> FilePath -> FilePath
<?.> ext :: FilePath
ext | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FilePath -> FilePath
takeExtension FilePath
s) = FilePath
s FilePath -> FilePath -> FilePath
<.> FilePath
ext
                  | Bool
otherwise              = FilePath
s

maybeCreateManifest
   :: DynFlags
   -> FilePath                          -- filename of executable
   -> IO [FilePath]                     -- extra objects to embed, maybe
maybeCreateManifest :: DynFlags -> FilePath -> IO [FilePath]
maybeCreateManifest dflags :: DynFlags
dflags exe_filename :: FilePath
exe_filename
 | Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 Bool -> Bool -> Bool
&&
   GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenManifest DynFlags
dflags
    = do let manifest_filename :: FilePath
manifest_filename = FilePath
exe_filename FilePath -> FilePath -> FilePath
<.> "manifest"

         FilePath -> FilePath -> IO ()
writeFile FilePath
manifest_filename (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
             "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "  <assemblyIdentity version=\"1.0.0.0\"\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "     processorArchitecture=\"X86\"\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "     name=\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
dropExtension FilePath
exe_filename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\"\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "     type=\"win32\"/>\n\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "    <security>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "      <requestedPrivileges>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "        </requestedPrivileges>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "       </security>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "  </trustInfo>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             "</assembly>\n"

         -- Windows will find the manifest file if it is named
         -- foo.exe.manifest. However, for extra robustness, and so that
         -- we can move the binary around, we can embed the manifest in
         -- the binary itself using windres:
         if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EmbedManifest DynFlags
dflags) then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else do

         FilePath
rc_filename <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule "rc"
         FilePath
rc_obj_filename <-
           DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_GhcSession (DynFlags -> FilePath
objectSuf DynFlags
dflags)

         FilePath -> FilePath -> IO ()
writeFile FilePath
rc_filename (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
             "1 24 MOVEABLE PURE " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
manifest_filename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\n"
               -- magic numbers :-)
               -- show is a bit hackish above, but we need to escape the
               -- backslashes in the path.

         DynFlags -> [Option] -> IO ()
runWindres DynFlags
dflags ([Option] -> IO ()) -> [Option] -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$
               ["--input="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
rc_filename,
                "--output="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
rc_obj_filename,
                "--output-format=coff"]
               -- no FileOptions here: windres doesn't like seeing
               -- backslashes, apparently

         FilePath -> IO ()
removeFile FilePath
manifest_filename

         [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
rc_obj_filename]
 | Bool
otherwise = [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []


linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkDynLibCheck :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkDynLibCheck dflags :: DynFlags
dflags o_files :: [FilePath]
o_files dep_packages :: [InstalledUnitId]
dep_packages
 = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
haveRtsOptsFlags DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      LogAction
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevInfo SrcSpan
noSrcSpan
          (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags)
          (FilePath -> SDoc
text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." SDoc -> SDoc -> SDoc
$$
           FilePath -> SDoc
text "    Call hs_init_ghc() from your main() function to set these options.")

    DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkDynLib DynFlags
dflags [FilePath]
o_files [InstalledUnitId]
dep_packages

-- | Linking a static lib will not really link anything. It will merely produce
-- a static archive of all dependent static libraries. The resulting library
-- will still need to be linked with any remaining link flags.
linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkStaticLib :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
linkStaticLib dflags :: DynFlags
dflags o_files :: [FilePath]
o_files dep_packages :: [InstalledUnitId]
dep_packages = do
  let extra_ld_inputs :: [FilePath]
extra_ld_inputs = [ FilePath
f | FileOption _ f :: FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
      modules :: [FilePath]
modules = [FilePath]
o_files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_ld_inputs
      output_fn :: FilePath
output_fn = Bool -> DynFlags -> FilePath
exeFileName Bool
True DynFlags
dflags

  FilePath
full_output_fn <- if FilePath -> Bool
isAbsolute FilePath
output_fn
                    then FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
output_fn
                    else do FilePath
d <- IO FilePath
getCurrentDirectory
                            FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
normalise (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
output_fn)
  Bool
output_exists <- FilePath -> IO Bool
doesFileExist FilePath
full_output_fn
  (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
output_exists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
full_output_fn

  [PackageConfig]
pkg_cfgs <- DynFlags -> [InstalledUnitId] -> IO [PackageConfig]
getPreloadPackagesAnd DynFlags
dflags [InstalledUnitId]
dep_packages
  [FilePath]
archives <- [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageConfig -> IO [FilePath])
-> [PackageConfig] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags -> PackageConfig -> IO [FilePath]
collectArchives DynFlags
dflags) [PackageConfig]
pkg_cfgs

  Archive
ar <- (Archive -> Archive -> Archive) -> Archive -> [Archive] -> Archive
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Archive -> Archive -> Archive
forall a. Monoid a => a -> a -> a
mappend
        (Archive -> [Archive] -> Archive)
-> IO Archive -> IO ([Archive] -> Archive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ArchiveEntry] -> Archive
Archive ([ArchiveEntry] -> Archive) -> IO [ArchiveEntry] -> IO Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO ArchiveEntry) -> [FilePath] -> IO [ArchiveEntry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO ArchiveEntry
loadObj [FilePath]
modules)
        IO ([Archive] -> Archive) -> IO [Archive] -> IO Archive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> IO Archive) -> [FilePath] -> IO [Archive]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO Archive
loadAr [FilePath]
archives

  if Settings -> Bool
sLdIsGnuLd (DynFlags -> Settings
settings DynFlags
dflags)
    then FilePath -> Archive -> IO ()
writeGNUAr FilePath
output_fn (Archive -> IO ()) -> Archive -> IO ()
forall a b. (a -> b) -> a -> b
$ (ArchiveEntry -> Bool) -> Archive -> Archive
afilter (Bool -> Bool
not (Bool -> Bool) -> (ArchiveEntry -> Bool) -> ArchiveEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveEntry -> Bool
isGNUSymdef) Archive
ar
    else FilePath -> Archive -> IO ()
writeBSDAr FilePath
output_fn (Archive -> IO ()) -> Archive -> IO ()
forall a b. (a -> b) -> a -> b
$ (ArchiveEntry -> Bool) -> Archive -> Archive
afilter (Bool -> Bool
not (Bool -> Bool) -> (ArchiveEntry -> Bool) -> ArchiveEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveEntry -> Bool
isBSDSymdef) Archive
ar

  -- run ranlib over the archive. write*Ar does *not* create the symbol index.
  DynFlags -> [Option] -> IO ()
runRanlib DynFlags
dflags [FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
output_fn]

-- -----------------------------------------------------------------------------
-- Running CPP

doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp dflags :: DynFlags
dflags raw :: Bool
raw input_fn :: FilePath
input_fn output_fn :: FilePath
output_fn = do
    let hscpp_opts :: [FilePath]
hscpp_opts = DynFlags -> [FilePath]
picPOpts DynFlags
dflags
    let cmdline_include_paths :: IncludeSpecs
cmdline_include_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags

    [FilePath]
pkg_include_dirs <- DynFlags -> [InstalledUnitId] -> IO [FilePath]
getPackageIncludePath DynFlags
dflags []
    let include_paths_global :: [FilePath]
include_paths_global = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ x :: FilePath
x xs :: [FilePath]
xs -> ("-I" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
          (IncludeSpecs -> [FilePath]
includePathsGlobal IncludeSpecs
cmdline_include_paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_include_dirs)
    let include_paths_quote :: [FilePath]
include_paths_quote = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ x :: FilePath
x xs :: [FilePath]
xs -> ("-iquote" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
          (IncludeSpecs -> [FilePath]
includePathsQuote IncludeSpecs
cmdline_include_paths)
    let include_paths :: [FilePath]
include_paths = [FilePath]
include_paths_quote [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
include_paths_global

    let verbFlags :: [FilePath]
verbFlags = DynFlags -> [FilePath]
getVerbFlags DynFlags
dflags

    let cpp_prog :: [Option] -> IO ()
cpp_prog args :: [Option]
args | Bool
raw       = DynFlags -> [Option] -> IO ()
SysTools.runCpp DynFlags
dflags [Option]
args
                      | Bool
otherwise = DynFlags -> [Option] -> IO ()
SysTools.runCc DynFlags
dflags (FilePath -> Option
SysTools.Option "-E" Option -> [Option] -> [Option]
forall a. a -> [a] -> [a]
: [Option]
args)

    let target_defs :: [FilePath]
target_defs =
          [ "-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HOST_OS     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "_BUILD_OS",
            "-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HOST_ARCH   ++ "_BUILD_ARCH",
            "-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TARGET_OS   ++ "_HOST_OS",
            "-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TARGET_ARCH ++ "_HOST_ARCH" ]
        -- remember, in code we *compile*, the HOST is the same our TARGET,
        -- and BUILD is the same as our HOST.

    let sse_defs :: [FilePath]
sse_defs =
          [ "-D__SSE__"      | DynFlags -> Bool
isSseEnabled      DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
          [ "-D__SSE2__"     | DynFlags -> Bool
isSse2Enabled     DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
          [ "-D__SSE4_2__"   | DynFlags -> Bool
isSse4_2Enabled   DynFlags
dflags ]

    let avx_defs :: [FilePath]
avx_defs =
          [ "-D__AVX__"      | DynFlags -> Bool
isAvxEnabled      DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
          [ "-D__AVX2__"     | DynFlags -> Bool
isAvx2Enabled     DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
          [ "-D__AVX512CD__" | DynFlags -> Bool
isAvx512cdEnabled DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
          [ "-D__AVX512ER__" | DynFlags -> Bool
isAvx512erEnabled DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
          [ "-D__AVX512F__"  | DynFlags -> Bool
isAvx512fEnabled  DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
          [ "-D__AVX512PF__" | DynFlags -> Bool
isAvx512pfEnabled DynFlags
dflags ]

    [FilePath]
backend_defs <- DynFlags -> IO [FilePath]
getBackendDefs DynFlags
dflags

    let th_defs :: [FilePath]
th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
    -- Default CPP defines in Haskell source
    FilePath
ghcVersionH <- DynFlags -> IO FilePath
getGhcVersionPathName DynFlags
dflags
    let hsSourceCppOpts :: [FilePath]
hsSourceCppOpts = [ "-include", FilePath
ghcVersionH ]

    -- MIN_VERSION macros
    let uids :: [UnitId]
uids = PackageState -> [UnitId]
explicitPackages (DynFlags -> PackageState
pkgState DynFlags
dflags)
        pkgs :: [PackageConfig]
pkgs = [Maybe PackageConfig] -> [PackageConfig]
forall a. [Maybe a] -> [a]
catMaybes ((UnitId -> Maybe PackageConfig)
-> [UnitId] -> [Maybe PackageConfig]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage DynFlags
dflags) [UnitId]
uids)
    [Option]
mb_macro_include <-
        if Bool -> Bool
not ([PackageConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageConfig]
pkgs) Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_VersionMacros DynFlags
dflags
            then do FilePath
macro_stub <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule "h"
                    FilePath -> FilePath -> IO ()
writeFile FilePath
macro_stub ([PackageConfig] -> FilePath
generatePackageVersionMacros [PackageConfig]
pkgs)
                    -- Include version macros for every *exposed* package.
                    -- Without -hide-all-packages and with a package database
                    -- size of 1000 packages, it takes cpp an estimated 2
                    -- milliseconds to process this file. See Trac #10970
                    -- comment 8.
                    [Option] -> IO [Option]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> FilePath -> Option
SysTools.FileOption "-include" FilePath
macro_stub]
            else [Option] -> IO [Option]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    [Option] -> IO ()
cpp_prog       (   (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
verbFlags
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
include_paths
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
hsSourceCppOpts
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
target_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
backend_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
th_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
hscpp_opts
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
sse_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
SysTools.Option [FilePath]
avx_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
mb_macro_include
        -- Set the language mode to assembler-with-cpp when preprocessing. This
        -- alleviates some of the C99 macro rules relating to whitespace and the hash
        -- operator, which we tend to abuse. Clang in particular is not very happy
        -- about this.
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
SysTools.Option     "-x"
                       , FilePath -> Option
SysTools.Option     "assembler-with-cpp"
                       , FilePath -> Option
SysTools.Option     FilePath
input_fn
        -- We hackily use Option instead of FileOption here, so that the file
        -- name is not back-slashed on Windows.  cpp is capable of
        -- dealing with / in filenames, so it works fine.  Furthermore
        -- if we put in backslashes, cpp outputs #line directives
        -- with *double* backslashes.   And that in turn means that
        -- our error messages get double backslashes in them.
        -- In due course we should arrange that the lexer deals
        -- with these \\ escapes properly.
                       , FilePath -> Option
SysTools.Option     "-o"
                       , FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
output_fn
                       ])

getBackendDefs :: DynFlags -> IO [String