{-# 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]
getBackendDefs :: DynFlags -> IO [FilePath]
getBackendDefs dflags :: DynFlags
dflags | DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscLlvm = do
    Maybe LlvmVersion
llvmVer <- DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion DynFlags
dflags
    [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
$ case Maybe LlvmVersion
llvmVer of
               Just (LlvmVersion n :: Int
n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> FilePath
format (Int
n,0) ]
               Just (LlvmVersionOld m :: Int
m n :: Int
n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> FilePath
format (Int
m,Int
n) ]
               _      -> []
  where
    format :: (Int, Int) -> FilePath
format (major :: Int
major, minor :: Int
minor)
      | Int
minor Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 100 = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error "getBackendDefs: Unsupported minor version"
      | Bool
otherwise = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ (100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
major Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
minor :: Int) -- Contract is Int

getBackendDefs _ =
    [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- ---------------------------------------------------------------------------
-- Macros (cribbed from Cabal)

generatePackageVersionMacros :: [PackageConfig] -> String
generatePackageVersionMacros :: [PackageConfig] -> FilePath
generatePackageVersionMacros pkgs :: [PackageConfig]
pkgs = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  -- Do not add any C-style comments. See Trac #3389.
  [ FilePath -> FilePath -> Version -> FilePath
generateMacros "" FilePath
pkgname Version
version
  | PackageConfig
pkg <- [PackageConfig]
pkgs
  , let version :: Version
version = PackageConfig -> Version
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> Version
packageVersion PackageConfig
pkg
        pkgname :: FilePath
pkgname = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar (PackageConfig -> FilePath
packageNameString PackageConfig
pkg)
  ]

fixchar :: Char -> Char
fixchar :: Char -> Char
fixchar '-' = '_'
fixchar c :: Char
c   = Char
c

generateMacros :: String -> String -> Version -> String
generateMacros :: FilePath -> FilePath -> Version -> FilePath
generateMacros prefix :: FilePath
prefix name :: FilePath
name version :: Version
version =
  [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  ["#define ", FilePath
prefix, "VERSION_",FilePath
name," ",FilePath -> FilePath
forall a. Show a => a -> FilePath
show (Version -> FilePath
showVersion Version
version),"\n"
  ,"#define MIN_", FilePath
prefix, "VERSION_",FilePath
name,"(major1,major2,minor) (\\\n"
  ,"  (major1) <  ",FilePath
major1," || \\\n"
  ,"  (major1) == ",FilePath
major1," && (major2) <  ",FilePath
major2," || \\\n"
  ,"  (major1) == ",FilePath
major1," && (major2) == ",FilePath
major2," && (minor) <= ",FilePath
minor,")"
  ,"\n\n"
  ]
  where
    (major1 :: FilePath
major1:major2 :: FilePath
major2:minor :: FilePath
minor:_) = (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FilePath
forall a. Show a => a -> FilePath
show (Version -> [Int]
versionBranch Version
version [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall a. a -> [a]
repeat 0)

-- ---------------------------------------------------------------------------
-- join object files into a single relocatable object file, using ld -r

{-
Note [Produce big objects on Windows]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The Windows Portable Executable object format has a limit of 32k sections, which
we tend to blow through pretty easily. Thankfully, there is a "big object"
extension, which raises this limit to 2^32. However, it must be explicitly
enabled in the toolchain:

 * the assembler accepts the -mbig-obj flag, which causes it to produce a
   bigobj-enabled COFF object.

 * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name
   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a
   PE executable.

We must enable bigobj output in a few places:

 * When merging object files (DriverPipeline.joinObjectFiles)

 * When assembling (DriverPipeline.runPhase (RealPhase As ...))

Unfortunately the big object format is not supported on 32-bit targets so
none of this can be used in that case.
-}

joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles dflags :: DynFlags
dflags o_files :: [FilePath]
o_files output_fn :: FilePath
output_fn = do
  let mySettings :: Settings
mySettings = DynFlags -> Settings
settings DynFlags
dflags
      ldIsGnuLd :: Bool
ldIsGnuLd = Settings -> Bool
sLdIsGnuLd Settings
mySettings
      osInfo :: OS
osInfo = Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
      ld_r :: [Option] -> CompilerInfo -> IO ()
ld_r args :: [Option]
args cc :: CompilerInfo
cc = DynFlags -> [Option] -> IO ()
SysTools.runLink DynFlags
dflags ([
                       FilePath -> Option
SysTools.Option "-nostdlib",
                       FilePath -> Option
SysTools.Option "-Wl,-r"
                     ]
                        -- See Note [No PIE while linking] in DynFlags
                     [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (if Settings -> Bool
sGccSupportsNoPie Settings
mySettings
                          then [FilePath -> Option
SysTools.Option "-no-pie"]
                          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
cc CompilerInfo -> CompilerInfo -> Bool
forall a. Eq a => a -> a -> Bool
==) [CompilerInfo
Clang, CompilerInfo
AppleClang, CompilerInfo
AppleClang51]
                          then []
                          else [FilePath -> Option
SysTools.Option "-nodefaultlibs"])
                     [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (if OS
osInfo OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSFreeBSD
                          then [FilePath -> Option
SysTools.Option "-L/usr/lib"]
                          else [])
                        -- gcc on sparc sets -Wl,--relax implicitly, but
                        -- -r and --relax are incompatible for ld, so
                        -- disable --relax explicitly.
                     [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (if Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                                Arch -> [Arch] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Arch
ArchSPARC, Arch
ArchSPARC64]
                         Bool -> Bool -> Bool
&& Bool
ldIsGnuLd
                            then [FilePath -> Option
SysTools.Option "-Wl,-no-relax"]
                            else [])
                        -- See Note [Produce big objects on Windows]
                     [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"
                        | OS
OSMinGW32 OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
osInfo
                        , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                        ]
                     [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]
ld_build_id
                     [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]
args)

      -- suppress the generation of the .note.gnu.build-id section,
      -- which we don't need and sometimes causes ld to emit a
      -- warning:
      ld_build_id :: [FilePath]
ld_build_id | Settings -> Bool
sLdSupportsBuildId Settings
mySettings = ["-Wl,--build-id=none"]
                  | Bool
otherwise                     = []

  CompilerInfo
ccInfo <- DynFlags -> IO CompilerInfo
getCompilerInfo DynFlags
dflags
  if Bool
ldIsGnuLd
     then do
          FilePath
script <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule "ldscript"
          FilePath
cwd <- IO FilePath
getCurrentDirectory
          let o_files_abs :: [FilePath]
o_files_abs = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: FilePath
x -> "\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath
cwd FilePath -> FilePath -> FilePath
</> FilePath
x) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "\"") [FilePath]
o_files
          FilePath -> FilePath -> IO ()
writeFile FilePath
script (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "INPUT(" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
o_files_abs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ")"
          [Option] -> CompilerInfo -> IO ()
ld_r [FilePath -> FilePath -> Option
SysTools.FileOption "" FilePath
script] CompilerInfo
ccInfo
     else if Settings -> Bool
sLdSupportsFilelist Settings
mySettings
     then do
          FilePath
filelist <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule "filelist"
          FilePath -> FilePath -> IO ()
writeFile FilePath
filelist (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
o_files
          [Option] -> CompilerInfo -> IO ()
ld_r [FilePath -> Option
SysTools.Option "-Wl,-filelist",
                FilePath -> FilePath -> Option
SysTools.FileOption "-Wl," FilePath
filelist] CompilerInfo
ccInfo
     else do
          [Option] -> CompilerInfo -> IO ()
ld_r ((FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> Option
SysTools.FileOption "") [FilePath]
o_files) CompilerInfo
ccInfo

-- -----------------------------------------------------------------------------
-- Misc.

writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode dflags :: DynFlags
dflags =
 GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags Bool -> Bool -> Bool
&&
 HscTarget
HscNothing HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> HscTarget
hscTarget DynFlags
dflags

-- | Figure out if a source file was modified after an output file (or if we
-- anyways need to consider the source file modified since the output is gone).
sourceModified :: FilePath -- ^ destination file we are looking for
               -> UTCTime  -- ^ last time of modification of source file
               -> IO Bool  -- ^ do we need to regenerate the output?
sourceModified :: FilePath -> UTCTime -> IO Bool
sourceModified dest_file :: FilePath
dest_file src_timestamp :: UTCTime
src_timestamp = do
  Bool
dest_file_exists <- FilePath -> IO Bool
doesFileExist FilePath
dest_file
  if Bool -> Bool
not Bool
dest_file_exists
    then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True       -- Need to recompile
     else do UTCTime
t2 <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
dest_file
             Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t2 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
src_timestamp)

-- | What phase to run after one of the backend code generators has run
hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
hscPostBackendPhase _ HsBootFile _    =  Phase
StopLn
hscPostBackendPhase _ HsigFile _      =  Phase
StopLn
hscPostBackendPhase dflags :: DynFlags
dflags _ hsc_lang :: HscTarget
hsc_lang =
  case HscTarget
hsc_lang of
        HscC -> Phase
HCc
        HscAsm | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags -> Phase
Splitter
               | Bool
otherwise                 -> Bool -> Phase
As Bool
False
        HscLlvm        -> Phase
LlvmOpt
        HscNothing     -> Phase
StopLn
        HscInterpreted -> Phase
StopLn

touchObjectFile :: DynFlags -> FilePath -> IO ()
touchObjectFile :: DynFlags -> FilePath -> IO ()
touchObjectFile dflags :: DynFlags
dflags path :: FilePath
path = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
path
  DynFlags -> FilePath -> FilePath -> IO ()
SysTools.touch DynFlags
dflags "Touching object file" FilePath
path

-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName dflags :: DynFlags
dflags = do
  [FilePath]
candidates <- case DynFlags -> Maybe FilePath
ghcVersionFile DynFlags
dflags of
    Just path :: FilePath
path -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
path]
    Nothing -> ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> "ghcversion.h")) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               (DynFlags -> [InstalledUnitId] -> IO [FilePath]
getPackageIncludePath DynFlags
dflags [UnitId -> InstalledUnitId
toInstalledUnitId UnitId
rtsUnitId])

  [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]
candidates
  case [FilePath]
found of
      []    -> GhcException -> IO FilePath
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
InstallationError
                                    ("ghcversion.h missing; tried: "
                                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate ", " [FilePath]
candidates))
      (x :: FilePath
x:_) -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
x

-- Note [-fPIC for assembler]
-- When compiling .c source file GHC's driver pipeline basically
-- does the following two things:
--   1. ${CC}              -S 'PIC_CFLAGS' source.c
--   2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
--
-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
-- Because on some architectures (at least sparc32) assembler also chooses
-- the relocation type!
-- Consider the following C module:
--
--     /* pic-sample.c */
--     int v;
--     void set_v (int n) { v = n; }
--     int  get_v (void)  { return v; }
--
--     $ gcc -S -fPIC pic-sample.c
--     $ gcc -c       pic-sample.s -o pic-sample.no-pic.o # incorrect binary
--     $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o    # correct binary
--
--     $ objdump -r -d pic-sample.pic.o    > pic-sample.pic.o.od
--     $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
--     $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
--
-- Most of architectures won't show any difference in this test, but on sparc32
-- the following assembly snippet:
--
--    sethi   %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
--
-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
--
--       3c:  2f 00 00 00     sethi  %hi(0), %l7
--    -                       3c: R_SPARC_PC22        _GLOBAL_OFFSET_TABLE_-0x8
--    +                       3c: R_SPARC_HI22        _GLOBAL_OFFSET_TABLE_-0x8

{- Note [Don't normalise input filenames]

Summary
  We used to normalise input filenames when starting the unlit phase. This
  broke hpc in `--make` mode with imported literate modules (#2991).

Introduction
  1) --main
  When compiling a module with --main, GHC scans its imports to find out which
  other modules it needs to compile too. It turns out that there is a small
  difference between saying `ghc --make A.hs`, when `A` imports `B`, and
  specifying both modules on the command line with `ghc --make A.hs B.hs`. In
  the former case, the filename for B is inferred to be './B.hs' instead of
  'B.hs'.

  2) unlit
  When GHC compiles a literate haskell file, the source code first needs to go
  through unlit, which turns it into normal Haskell source code. At the start
  of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the
  option `-h` and the name of the original file. We used to normalise this
  filename using System.FilePath.normalise, which among other things removes
  an initial './'. unlit then uses that filename in #line directives that it
  inserts in the transformed source code.

  3) SrcSpan
  A SrcSpan represents a portion of a source code file. It has fields
  linenumber, start column, end column, and also a reference to the file it
  originated from. The SrcSpans for a literate haskell file refer to the
  filename that was passed to unlit -h.

  4) -fhpc
  At some point during compilation with -fhpc, in the function
  `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a
  `SrcSpan` refers to with the name of the file we are currently compiling.
  For some reason I don't yet understand, they can sometimes legitimally be
  different, and then hpc ignores that SrcSpan.

Problem
  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate
  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the
  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).
  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are
  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),
  doesn't include ticks for B, and we have unhappy customers (#2991).

Solution
  Do not normalise `input_fn` when starting the unlit phase.

Alternative solution
  Another option would be to not compare the two filenames on equality, but to
  use System.FilePath.equalFilePath. That function first normalises its
  arguments. The problem is that by the time we need to do the comparison, the
  filenames have been turned into FastStrings, probably for performance
  reasons, so System.FilePath.equalFilePath can not be used directly.

Archeology
  The call to `normalise` was added in a commit called "Fix slash
  direction on Windows with the new filePath code" (c9b6b5e8). The problem
  that commit was addressing has since been solved in a different manner, in a
  commit called "Fix the filename passed to unlit" (1eedbc6b). So the
  `normalise` is no longer necessary.
-}