{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

module GHC.Driver.Pipeline (
        -- 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,
   doCpp,
   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
  ) where

#include <ghcplatform.h>
#include "HsVersions.h"

import GHC.Prelude

import GHC.Driver.Pipeline.Monad
import GHC.Unit.State
import GHC.Driver.Ways
import GHC.Parser.Header
import GHC.Driver.Phases
import GHC.SysTools
import GHC.SysTools.ExtraObj
import GHC.Driver.Main
import GHC.Driver.Finder
import GHC.Driver.Types hiding ( Hsc )
import GHC.Utils.Outputable
import GHC.Unit.Module
import GHC.Utils.Error
import GHC.Driver.Session
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer )
import GHC.Types.Basic       ( SuccessFlag(..) )
import GHC.Data.Maybe        ( expectJust )
import GHC.Types.SrcLoc
import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList )
import GHC.Utils.Monad
import GHC.Platform
import GHC.Tc.Types
import GHC.Driver.Hooks
import qualified GHC.LanguageExtensions as LangExt
import GHC.SysTools.FileCleanup
import GHC.SysTools.Ar
import GHC.Settings
import GHC.Data.Bag             ( unitBag )
import GHC.Data.FastString      ( mkFastString )
import GHC.Iface.Make           ( mkFullIface )

import GHC.Utils.Exception as Exception
import System.Directory
import System.FilePath
import System.IO
import Control.Monad
import qualified Control.Monad.Catch as MC (handle)
import Data.List        ( isInfixOf, 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
-> String
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, String))
preprocess HscEnv
hsc_env String
input_fn Maybe InputFileBuffer
mb_input_buf Maybe Phase
mb_phase =
  (SourceError -> IO (Either ErrorMessages (DynFlags, String)))
-> IO (Either ErrorMessages (DynFlags, String))
-> IO (Either ErrorMessages (DynFlags, String))
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
err -> Either ErrorMessages (DynFlags, String)
-> IO (Either ErrorMessages (DynFlags, String))
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorMessages -> Either ErrorMessages (DynFlags, String)
forall a b. a -> Either a b
Left (SourceError -> ErrorMessages
srcErrorMessages SourceError
err))) (IO (Either ErrorMessages (DynFlags, String))
 -> IO (Either ErrorMessages (DynFlags, String)))
-> IO (Either ErrorMessages (DynFlags, String))
-> IO (Either ErrorMessages (DynFlags, String))
forall a b. (a -> b) -> a -> b
$
  (GhcException -> IO (Either ErrorMessages (DynFlags, String)))
-> IO (Either ErrorMessages (DynFlags, String))
-> IO (Either ErrorMessages (DynFlags, String))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle GhcException -> IO (Either ErrorMessages (DynFlags, String))
forall {b}. GhcException -> IO (Either ErrorMessages b)
handler (IO (Either ErrorMessages (DynFlags, String))
 -> IO (Either ErrorMessages (DynFlags, String)))
-> IO (Either ErrorMessages (DynFlags, String))
-> IO (Either ErrorMessages (DynFlags, String))
forall a b. (a -> b) -> a -> b
$
  ((DynFlags, String) -> Either ErrorMessages (DynFlags, String))
-> IO (DynFlags, String)
-> IO (Either ErrorMessages (DynFlags, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags, String) -> Either ErrorMessages (DynFlags, String)
forall a b. b -> Either a b
Right (IO (DynFlags, String)
 -> IO (Either ErrorMessages (DynFlags, String)))
-> IO (DynFlags, String)
-> IO (Either ErrorMessages (DynFlags, String))
forall a b. (a -> b) -> a -> b
$ do
  MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
  (DynFlags
dflags, String
fp, Maybe ModIface
mb_iface) <- Phase
-> HscEnv
-> (String, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe String
-> PipelineOutput
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline Phase
anyHsc HscEnv
hsc_env (String
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 String
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-}
  -- We stop before Hsc phase so we shouldn't generate an interface
  MASSERT(isNothing mb_iface)
  (DynFlags, String) -> IO (DynFlags, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags, String
fp)
  where
    srcspan :: SrcSpan
srcspan = SrcLoc -> SrcSpan
srcLocSpan (SrcLoc -> SrcSpan) -> SrcLoc -> SrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
mkFastString String
input_fn) Int
1 Int
1
    handler :: GhcException -> IO (Either ErrorMessages b)
handler (ProgramError String
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
$ String -> SDoc
text String
msg
    handler 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' Maybe TcGblEnv
m_tc_result Maybe Messager
mHscMessage
            HscEnv
hsc_env0 ModSummary
summary Int
mod_index Int
nmods Maybe ModIface
mb_old_iface Maybe Linkable
mb_old_linkable
            SourceModified
source_modified0
 = do

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

   -- Run the pipeline up to codeGen (so everything up to, but not including, STG)
   (HscStatus
status, DynFlags
plugin_dflags) <- Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, DynFlags)
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 -> [String] -> IO ()
addFilesToClean DynFlags
flags TempFileLifetime
TFL_CurrentModule ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
                   [ModLocation -> String
ml_hi_file (ModLocation -> String) -> ModLocation -> String
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 -> [String] -> IO ()
addFilesToClean DynFlags
flags TempFileLifetime
TFL_GhcSession ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
                   [ModLocation -> String
ml_obj_file (ModLocation -> String) -> ModLocation -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
summary]

   -- Use an HscEnv with DynFlags updated with the plugin info (returned from
   -- hscIncrementalCompile)
   let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env{ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
plugin_dflags }

   case (HscStatus
status, HscTarget
hsc_lang) of
        (HscUpToDate ModIface
iface ModDetails
hmi_details, HscTarget
_) ->
            -- TODO recomp014 triggers this assert. What's going on?!
            -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details Maybe Linkable
mb_old_linkable
        (HscNotGeneratingCode ModIface
iface ModDetails
hmi_details, HscTarget
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 -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details Maybe Linkable
mb_linkable
        (HscNotGeneratingCode ModIface
_ ModDetails
_, HscTarget
_) -> String -> IO HomeModInfo
forall a. String -> a
panic String
"compileOne HscNotGeneratingCode"
        (HscStatus
_, HscTarget
HscNothing) -> String -> IO HomeModInfo
forall a. String -> a
panic String
"compileOne HscNothing"
        (HscUpdateBoot ModIface
iface ModDetails
hmi_details, HscTarget
HscInterpreted) -> do
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details Maybe Linkable
forall a. Maybe a
Nothing
        (HscUpdateBoot ModIface
iface ModDetails
hmi_details, HscTarget
_) -> do
            DynFlags -> String -> IO ()
touchObjectFile DynFlags
dflags String
object_filename
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details Maybe Linkable
forall a. Maybe a
Nothing
        (HscUpdateSig ModIface
iface ModDetails
hmi_details, HscTarget
HscInterpreted) -> do
            let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM (ModSummary -> UTCTime
ms_hs_date ModSummary
summary) Module
this_mod []
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable)
        (HscUpdateSig ModIface
iface ModDetails
hmi_details, HscTarget
_) -> do
            String
output_fn <- Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Phase
next_phase
                            (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule) String
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, String, Maybe ModIface)
_ <- Phase
-> HscEnv
-> (String, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe String
-> PipelineOutput
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline Phase
StopLn HscEnv
hsc_env'
                              (String
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 (ModIface -> ModDetails -> HscStatus
HscUpdateSig ModIface
iface ModDetails
hmi_details)))
                              (String -> Maybe String
forall a. a -> Maybe a
Just String
basename)
                              PipelineOutput
Persistent
                              (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
                              []
            UTCTime
o_time <- String -> IO UTCTime
getModificationUTCTime String
object_filename
            let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
o_time Module
this_mod [String -> Unlinked
DotO String
object_filename]
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable)
        (HscRecomp { hscs_guts :: HscStatus -> CgGuts
hscs_guts = CgGuts
cgguts,
                     hscs_mod_location :: HscStatus -> ModLocation
hscs_mod_location = ModLocation
mod_location,
                     hscs_partial_iface :: HscStatus -> PartialModIface
hscs_partial_iface = PartialModIface
partial_iface,
                     hscs_old_iface_hash :: HscStatus -> Maybe Fingerprint
hscs_old_iface_hash = Maybe Fingerprint
mb_old_iface_hash,
                     hscs_iface_dflags :: HscStatus -> DynFlags
hscs_iface_dflags = DynFlags
iface_dflags }, HscTarget
HscInterpreted) -> do
            -- In interpreted mode the regular codeGen backend is not run so we
            -- generate a interface without codeGen info.
            let hsc_env'' :: HscEnv
hsc_env'' = HscEnv
hsc_env'{hsc_dflags :: DynFlags
hsc_dflags=DynFlags
iface_dflags}
            ModIface
final_iface <- HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
mkFullIface HscEnv
hsc_env'' PartialModIface
partial_iface Maybe CgInfos
forall a. Maybe a
Nothing
            -- Reconstruct the `ModDetails` from the just-constructed `ModIface`
            -- See Note [ModDetails and --make mode]
            ModDetails
hmi_details <- IO ModDetails -> IO ModDetails
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModDetails -> IO ModDetails) -> IO ModDetails -> IO ModDetails
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails HscEnv
hsc_env'' ModSummary
summary ModIface
final_iface
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
hscMaybeWriteIface DynFlags
dflags ModIface
final_iface Maybe Fingerprint
mb_old_iface_hash (ModSummary -> ModLocation
ms_location ModSummary
summary)

            (Maybe String
hasStub, CompiledByteCode
comp_bc, [SptEntry]
spt_entries) <- HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe String, CompiledByteCode, [SptEntry])
hscInteractive HscEnv
hsc_env' CgGuts
cgguts ModLocation
mod_location

            [Unlinked]
stub_o <- case Maybe String
hasStub of
                      Maybe String
Nothing -> [Unlinked] -> IO [Unlinked]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                      Just String
stub_c -> do
                          String
stub_o <- HscEnv -> String -> IO String
compileStub HscEnv
hsc_env' String
stub_c
                          [Unlinked] -> IO [Unlinked]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Unlinked
DotO String
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 -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
final_iface ModDetails
hmi_details (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable)
        (HscRecomp{}, HscTarget
_) -> do
            String
output_fn <- Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Phase
next_phase
                            (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule)
                            String
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
_, String
_, Just ModIface
iface) <- Phase
-> HscEnv
-> (String, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe String
-> PipelineOutput
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline Phase
StopLn HscEnv
hsc_env'
                              (String
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
status))
                              (String -> Maybe String
forall a. a -> Maybe a
Just String
basename)
                              PipelineOutput
Persistent
                              (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
                              []
                  -- The object filename comes from the ModLocation
            UTCTime
o_time <- String -> IO UTCTime
getModificationUTCTime String
object_filename
            let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
o_time Module
this_mod [String -> Unlinked
DotO String
object_filename]
            -- See Note [ModDetails and --make mode]
            ModDetails
details <- HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails HscEnv
hsc_env' ModSummary
summary ModIface
iface
            HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details (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 :: String
input_fn    = String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"compile:hs" (ModLocation -> Maybe String
ml_hs_file ModLocation
location)
       input_fnpp :: String
input_fnpp  = ModSummary -> String
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) -> Set 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 -> Set Way
ways DynFlags
dflags0)
       isProfWay :: Bool
isProfWay   = (Way -> Bool) -> Set 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 -> Set 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 = HscSource -> HscTarget -> Phase
hscPostBackendPhase HscSource
src_flavour HscTarget
hsc_lang
       object_filename :: String
object_filename = ModLocation -> String
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
hostIsDynamic 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 :: String
basename = String -> String
dropExtension String
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 :: String
current_dir = String -> String
takeDirectory String
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 -> [String] -> IncludeSpecs
addImplicitQuoteInclude IncludeSpecs
old_paths [String
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
                                             HscTarget
HscInterpreted -> Bool
True
                                             HscTarget
_ -> 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 -> String -> IO String
compileForeign HscEnv
_ ForeignSrcLang
RawObject String
object_file = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
object_file
compileForeign HscEnv
hsc_env ForeignSrcLang
lang String
stub_c = do
        let phase :: Phase
phase = case ForeignSrcLang
lang of
              ForeignSrcLang
LangC      -> Phase
Cc
              ForeignSrcLang
LangCxx    -> Phase
Ccxx
              ForeignSrcLang
LangObjc   -> Phase
Cobjc
              ForeignSrcLang
LangObjcxx -> Phase
Cobjcxx
              ForeignSrcLang
LangAsm    -> Bool -> Phase
As Bool
True -- allow CPP
#if __GLASGOW_HASKELL__ < 811
              RawObject  -> panic "compileForeign: should be unreachable"
#endif
        (DynFlags
_, String
stub_o, Maybe ModIface
_) <- Phase
-> HscEnv
-> (String, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe String
-> PipelineOutput
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline Phase
StopLn HscEnv
hsc_env
                       (String
stub_c, Maybe InputFileBuffer
forall a. Maybe a
Nothing, PhasePlus -> Maybe PhasePlus
forall a. a -> Maybe a
Just (Phase -> PhasePlus
RealPhase Phase
phase))
                       Maybe String
forall a. Maybe a
Nothing (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_GhcSession)
                       Maybe ModLocation
forall a. Maybe a
Nothing{-no ModLocation-}
                       []
        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
stub_o

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

compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub :: DynFlags -> HscEnv -> String -> ModLocation -> ModuleName -> IO ()
compileEmptyStub DynFlags
dflags HscEnv
hsc_env String
basename ModLocation
location 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
  -- https://gitlab.haskell.org/ghc/ghc/issues/12673
  -- and https://github.com/haskell/cabal/issues/2257
  String
empty_stub <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
"c"
  let src :: SDoc
src = String -> SDoc
text String
"int" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DynFlags -> ModuleName -> Module
mkHomeModule DynFlags
dflags ModuleName
mod_name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"= 0;"
  String -> String -> IO ()
writeFile String
empty_stub (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
CStyle SDoc
src))
  (DynFlags, String, Maybe ModIface)
_ <- Phase
-> HscEnv
-> (String, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe String
-> PipelineOutput
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline Phase
StopLn HscEnv
hsc_env
                  (String
empty_stub, Maybe InputFileBuffer
forall a. Maybe a
Nothing, Maybe PhasePlus
forall a. Maybe a
Nothing)
                  (String -> Maybe String
forall a. a -> Maybe a
Just String
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
--
-- Note [Dynamic linking on macOS]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Since macOS Sierra (10.14), the dynamic system linker enforces
-- a limit on the Load Commands.  Specifically the Load Command Size
-- Limit is at 32K (32768).  The Load Commands contain the install
-- name, dependencies, runpaths, and a few other commands.  We however
-- only have control over the install name, dependencies and runpaths.
--
-- The install name is the name by which this library will be
-- referenced.  This is such that we do not need to bake in the full
-- absolute location of the library, and can move the library around.
--
-- The dependency commands contain the install names from of referenced
-- libraries.  Thus if a libraries install name is @rpath/libHS...dylib,
-- that will end up as the dependency.
--
-- Finally we have the runpaths, which informs the linker about the
-- directories to search for the referenced dependencies.
--
-- The system linker can do recursive linking, however using only the
-- direct dependencies conflicts with ghc's ability to inline across
-- packages, and as such would end up with unresolved symbols.
--
-- Thus we will pass the full dependency closure to the linker, and then
-- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).
--
-- We still need to add the relevant runpaths, for the dynamic linker to
-- lookup the referenced libraries though.  The linker (ld64) does not
-- have any option to dead strip runpaths; which makes sense as runpaths
-- can be used for dependencies of dependencies as well.
--
-- The solution we then take in GHC is to not pass any runpaths to the
-- linker at link time, but inject them after the linking.  For this to
-- work we'll need to ask the linker to create enough space in the header
-- to add more runpaths after the linking (-headerpad 8000).
--
-- After the library has been linked by $LD (usually ld64), we will use
-- otool to inspect the libraries left over after dead stripping, compute
-- the relevant runpaths, and inject them into the linked product using
-- the install_name_tool command.
--
-- This strategy should produce the smallest possible set of load commands
-- while still retaining some form of relocatability via runpaths.
--
-- The only way I can see to reduce the load command size further would be
-- by shortening the library names, or start putting libraries into the same
-- folders, such that one runpath would be sufficient for multiple/all
-- libraries.
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 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 GhcLink
LinkInMemory DynFlags
_ Bool
_ HomePackageTable
_
      = if PlatformMisc -> Bool
platformMisc_ghcWithInterpreter (PlatformMisc -> Bool) -> PlatformMisc -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
        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 GhcLink
NoLink DynFlags
_ Bool
_ HomePackageTable
_
      = SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded

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

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

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

panicBadLink :: GhcLink -> a
panicBadLink :: forall a. GhcLink -> a
panicBadLink GhcLink
other = String -> a
forall a. String -> a
panic (String
"link: GHC not built to link this way: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            GhcLink -> String
forall a. Show a => a -> String
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' DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
   | Bool
batch_attempt_linking
   = do
        let
            staticLink :: Bool
staticLink = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
                          GhcLink
LinkStaticLib -> Bool
True
                          GhcLink
_ -> Bool
False

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

            -- the packages we depend on
            pkg_deps :: [UnitId]
pkg_deps  = (HomeModInfo -> [UnitId]) -> [HomeModInfo] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((UnitId, Bool) -> UnitId) -> [(UnitId, Bool)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, Bool) -> UnitId
forall a b. (a, b) -> a
fst ([(UnitId, Bool)] -> [UnitId])
-> (HomeModInfo -> [(UnitId, Bool)]) -> HomeModInfo -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(UnitId, Bool)]
dep_pkgs (Dependencies -> [(UnitId, Bool)])
-> (HomeModInfo -> Dependencies) -> HomeModInfo -> [(UnitId, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> 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 (String -> Maybe Linkable -> Linkable
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"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 Int
3 (String -> SDoc
text String
"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 Int
3 (String -> SDoc
text String
"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 -> [String]
getOfiles (LM UTCTime
_ Module
_ [Unlinked]
us) = (Unlinked -> String) -> [Unlinked] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Unlinked -> String
nameOfObject ((Unlinked -> Bool) -> [Unlinked] -> [Unlinked]
forall a. (a -> Bool) -> [a] -> [a]
filter Unlinked -> Bool
isObject [Unlinked]
us)
            obj_files :: [String]
obj_files = (Linkable -> [String]) -> [Linkable] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Linkable -> [String]
getOfiles [Linkable]
linkables

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

        Bool
linking_needed <- DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded DynFlags
dflags Bool
staticLink [Linkable]
linkables [UnitId]
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 Int
2 (String -> SDoc
text String
exe_file SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is up to date, linking not required.")
                   SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
           else do

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

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

        DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
3 (String -> SDoc
text String
"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 Int
3 (String -> SDoc
text String
"link(batch): upsweep (partially) failed OR" SDoc -> SDoc -> SDoc
$$
                                String -> SDoc
text String
"   Main.main not exported; not linking.")
        SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded


linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded DynFlags
dflags Bool
staticLink [Linkable]
linkables [UnitId]
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 :: String
exe_file = Bool -> DynFlags -> String
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
$ String -> IO UTCTime
getModificationUTCTime String
exe_file
  case Either IOException UTCTime
e_exe_time of
    Left IOException
_  -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Right UTCTime
t -> do
        -- first check object files and extra_ld_inputs
        let extra_ld_inputs :: [String]
extra_ld_inputs = [ String
f | FileOption String
_ String
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
        [Either IOException UTCTime]
e_extra_times <- (String -> IO (Either IOException UTCTime))
-> [String] -> 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))
-> (String -> IO UTCTime)
-> String
-> IO (Either IOException UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO UTCTime
getModificationUTCTime) [String]
extra_ld_inputs
        let ([IOException]
errs,[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 pkgstate :: UnitState
pkgstate = DynFlags -> UnitState
unitState DynFlags
dflags
        let pkg_hslibs :: [([String], String)]
pkg_hslibs  = [ (DynFlags -> [UnitInfo] -> [String]
collectLibraryPaths DynFlags
dflags [UnitInfo
c], String
lib)
                          | Just UnitInfo
c <- (UnitId -> Maybe UnitInfo) -> [UnitId] -> [Maybe UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
pkgstate) [UnitId]
pkg_deps,
                            String
lib <- DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags UnitInfo
c ]

        [Maybe String]
pkg_libfiles <- (([String], String) -> IO (Maybe String))
-> [([String], String)] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([String] -> String -> IO (Maybe String))
-> ([String], String) -> IO (Maybe String)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DynFlags -> [String] -> String -> IO (Maybe String)
findHSLib DynFlags
dflags)) [([String], String)]
pkg_hslibs
        if (Maybe String -> Bool) -> [Maybe String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe String]
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 <- (String -> IO (Either IOException UTCTime))
-> [String] -> 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))
-> (String -> IO UTCTime)
-> String
-> IO (Either IOException UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO UTCTime
getModificationUTCTime)
                          ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String]
pkg_libfiles)
        let ([IOException]
lib_errs,[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 -> [UnitId] -> String -> IO Bool
checkLinkInfo DynFlags
dflags [UnitId]
pkg_deps String
exe_file

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

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

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

compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile :: HscEnv -> Phase -> (String, Maybe Phase) -> IO String
compileFile HscEnv
hsc_env Phase
stop_phase (String
src, Maybe Phase
mb_phase) = do
   Bool
exists <- String -> IO Bool
doesFileExist String
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 (String -> GhcException
CmdLineError (String
"does not exist: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src))

   let
        dflags :: DynFlags
dflags    = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        mb_o_file :: Maybe String
mb_o_file = DynFlags -> Maybe String
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 String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mb_o_file = PipelineOutput
SpecificFile
                -- -o foo applies to the file we are compiling now
         | Bool
otherwise = PipelineOutput
Persistent

   ( DynFlags
_, String
out_file, Maybe ModIface
_) <- Phase
-> HscEnv
-> (String, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe String
-> PipelineOutput
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline Phase
stop_phase HscEnv
hsc_env
                            (String
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 String
forall a. Maybe a
Nothing
                            PipelineOutput
output
                            Maybe ModLocation
forall a. Maybe a
Nothing{-no ModLocation-} []
   String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
out_file


doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
doLink :: DynFlags -> Phase -> [String] -> IO ()
doLink DynFlags
dflags Phase
stop_phase [String]
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
        GhcLink
NoLink        -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        GhcLink
LinkBinary    -> DynFlags -> [String] -> [UnitId] -> IO ()
linkBinary         DynFlags
dflags [String]
o_files []
        GhcLink
LinkStaticLib -> DynFlags -> [String] -> [UnitId] -> IO ()
linkStaticLib      DynFlags
dflags [String]
o_files []
        GhcLink
LinkDynLib    -> DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck    DynFlags
dflags [String]
o_files []
        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, Maybe ModIface)
                                -- ^ (final flags, output filename, interface)
runPipeline :: Phase
-> HscEnv
-> (String, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe String
-> PipelineOutput
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline Phase
stop_phase HscEnv
hsc_env0 (String
input_fn, Maybe InputFileBuffer
mb_input_buf, Maybe PhasePlus
mb_phase)
             Maybe String
mb_basename PipelineOutput
output Maybe ModLocation
maybe_loc [String]
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 String
dumpPrefix = String -> Maybe String
forall a. a -> Maybe a
Just (String
basename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") }
             hsc_env :: HscEnv
hsc_env = HscEnv
hsc_env0 {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags}

             (String
input_basename, String
suffix) = String -> (String, String)
splitExtension String
input_fn
             suffix' :: String
suffix' = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
suffix -- strip off the .
             basename :: String
basename | Just String
b <- Maybe String
mb_basename = String
b
                      | Bool
otherwise             = String
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 (String -> Phase
startPhase String
suffix')) Maybe PhasePlus
mb_phase

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

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

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

         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
isBackpackishSuffix String
suffix') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
UsageError
                       (String
"use --backpack to process " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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' = Platform -> Phase -> Phase -> Bool
happensBefore (DynFlags -> Platform
targetPlatform DynFlags
dflags)
         case PhasePlus
start_phase of
             RealPhase 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 (String -> GhcException
UsageError
                                   (String
"cannot compile this file to desired target: "
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
input_fn))
             HscOut {} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

         DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
4 (String -> SDoc
text String
"Running the pipeline")
         (DynFlags, String, Maybe ModIface)
r <- PhasePlus
-> HscEnv
-> PipeEnv
-> String
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline' PhasePlus
start_phase HscEnv
hsc_env PipeEnv
env String
input_fn'
                           Maybe ModLocation
maybe_loc [String]
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 Int
4
                   (String -> SDoc
text String
"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, String, Maybe ModIface)
_ <- PhasePlus
-> HscEnv
-> PipeEnv
-> String
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline' PhasePlus
start_phase HscEnv
hsc_env' PipeEnv
env String
input_fn'
                                 Maybe ModLocation
maybe_loc [String]
foreign_os
               () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         (DynFlags, String, Maybe ModIface)
-> IO (DynFlags, String, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags, String, Maybe ModIface)
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, Maybe ModIface)
                                -- ^ (final flags, output filename, interface)
runPipeline' :: PhasePlus
-> HscEnv
-> PipeEnv
-> String
-> Maybe ModLocation
-> [String]
-> IO (DynFlags, String, Maybe ModIface)
runPipeline' PhasePlus
start_phase HscEnv
hsc_env PipeEnv
env String
input_fn
             Maybe ModLocation
maybe_loc [String]
foreign_os
  = do
  -- Execute the pipeline...
  let state :: PipeState
state = PipeState :: HscEnv
-> Maybe ModLocation -> [String] -> Maybe ModIface -> 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 :: [String]
foreign_os = [String]
foreign_os, iface :: Maybe ModIface
iface = Maybe ModIface
forall a. Maybe a
Nothing }
  (PipeState
pipe_state, String
fp) <- CompPipeline String
-> PipeEnv -> PipeState -> IO (PipeState, String)
forall a.
CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
evalP (PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
start_phase String
input_fn) PipeEnv
env PipeState
state
  (DynFlags, String, Maybe ModIface)
-> IO (DynFlags, String, Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState -> DynFlags
pipeStateDynFlags PipeState
pipe_state, String
fp, PipeState -> Maybe ModIface
pipeStateModIface PipeState
pipe_state)

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

-- | pipeLoop runs phases until we reach the stop phase
pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop :: PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
phase String
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' = Platform -> Phase -> Phase -> Bool
happensBefore (DynFlags -> Platform
targetPlatform DynFlags
dflags)
      stopPhase :: Phase
stopPhase = PipeEnv -> Phase
stop_phase PipeEnv
env
  case PhasePlus
phase of
   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 TempFileLifetime
_ ->
            String -> CompPipeline String
forall (m :: * -> *) a. Monad m => a -> m a
return String
input_fn
        PipelineOutput
output ->
            do PipeState
pst <- CompPipeline PipeState
getPipeState
               String
final_fn <- IO String -> CompPipeline String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> CompPipeline String)
-> IO String -> CompPipeline String
forall a b. (a -> b) -> a -> b
$ Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename
                                        Phase
stopPhase PipelineOutput
output (PipeEnv -> String
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 (String
final_fn String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
input_fn) (CompPipeline () -> CompPipeline ())
-> CompPipeline () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ do
                  let msg :: String
msg = (String
"Copying `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
input_fn String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"' to `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
final_fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")
                      line_prag :: Maybe String
line_prag = String -> Maybe String
forall a. a -> Maybe a
Just (String
"{-# LINE 1 \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PipeEnv -> String
src_filename PipeEnv
env String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" #-}\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 -> String -> Maybe String -> String -> String -> IO ()
copyWithHeader DynFlags
dflags String
msg Maybe String
line_prag String
input_fn String
final_fn
               String -> CompPipeline String
forall (m :: * -> *) a. Monad m => a -> m a
return String
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 #-}.
     -> String -> CompPipeline String
forall a. String -> a
panic (String
"pipeLoop: at phase " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Phase -> String
forall a. Show a => a -> String
show Phase
realPhase String -> String -> String
forall a. [a] -> [a] -> [a]
++
           String
" but I wanted to stop at phase " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Phase -> String
forall a. Show a => a -> String
show Phase
stopPhase)

   PhasePlus
_
     -> 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 Int
4
                                  (String -> SDoc
text String
"Running phase" SDoc -> SDoc -> SDoc
<+> PhasePlus -> SDoc
forall a. Outputable a => a -> SDoc
ppr PhasePlus
phase)
           (PhasePlus
next_phase, String
output_fn) <- PhasePlus -> String -> DynFlags -> CompPipeline (PhasePlus, String)
runHookedPhase PhasePlus
phase String
input_fn DynFlags
dflags
           case PhasePlus
phase of
               HscOut {} -> do
                   -- We don't pass Opt_BuildDynamicToo to the backend
                   -- in DynFlags.
                   -- Instead it's run twice with flags accordingly set
                   -- per run.
                   let noDynToo :: CompPipeline String
noDynToo = PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
next_phase String
output_fn
                   let dynToo :: CompPipeline String
dynToo = do
                          DynFlags -> CompPipeline ()
setDynFlags (DynFlags -> CompPipeline ()) -> DynFlags -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
dflags GeneralFlag
Opt_BuildDynamicToo
                          String
r <- PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
next_phase String
output_fn
                          DynFlags -> CompPipeline ()
setDynFlags (DynFlags -> CompPipeline ()) -> DynFlags -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
dynamicTooMkDynamicDynFlags DynFlags
dflags
                          -- TODO shouldn't ignore result:
                          String
_ <- PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
phase String
input_fn
                          String -> CompPipeline String
forall (m :: * -> *) a. Monad m => a -> m a
return String
r
                   DynFlags
-> CompPipeline String
-> CompPipeline String
-> CompPipeline String
forall (m :: * -> *) a. MonadIO m => DynFlags -> m a -> m a -> m a
ifGeneratingDynamicToo DynFlags
dflags CompPipeline String
dynToo CompPipeline String
noDynToo
               PhasePlus
_ -> PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
next_phase String
output_fn

runHookedPhase :: PhasePlus -> FilePath -> DynFlags
               -> CompPipeline (PhasePlus, FilePath)
runHookedPhase :: PhasePlus -> String -> DynFlags -> CompPipeline (PhasePlus, String)
runHookedPhase PhasePlus
pp String
input DynFlags
dflags =
  (Hooks
 -> Maybe
      (PhasePlus
       -> String -> DynFlags -> CompPipeline (PhasePlus, String)))
-> (PhasePlus
    -> String -> DynFlags -> CompPipeline (PhasePlus, String))
-> DynFlags
-> PhasePlus
-> String
-> DynFlags
-> CompPipeline (PhasePlus, String)
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks
-> Maybe
     (PhasePlus
      -> String -> DynFlags -> CompPipeline (PhasePlus, String))
runPhaseHook PhasePlus -> String -> DynFlags -> CompPipeline (PhasePlus, String)
runPhase DynFlags
dflags PhasePlus
pp String
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 String
phaseOutputFilename Phase
next_phase = do
  PipeEnv{Phase
stop_phase :: Phase
stop_phase :: PipeEnv -> Phase
stop_phase, String
src_basename :: String
src_basename :: PipeEnv -> String
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 String -> CompPipeline String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> CompPipeline String)
-> IO String -> CompPipeline String
forall a b. (a -> b) -> a -> b
$ Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Phase
stop_phase PipelineOutput
output_spec
                             String
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
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Phase
stop_phase PipelineOutput
output String
basename DynFlags
dflags Phase
next_phase Maybe ModLocation
maybe_location
 | Bool
is_last_phase, PipelineOutput
Persistent   <- PipelineOutput
output = IO String
persistent_fn
 | Bool
is_last_phase, PipelineOutput
SpecificFile <- PipelineOutput
output = case DynFlags -> Maybe String
outputFile DynFlags
dflags of
                                           Just String
f -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
f
                                           Maybe String
Nothing ->
                                               String -> IO String
forall a. String -> a
panic String
"SpecificFile: No filename"
 | Bool
keep_this_output                      = IO String
persistent_fn
 | Temporary TempFileLifetime
lifetime <- PipelineOutput
output          = DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
lifetime String
suffix
 | Bool
otherwise                             = DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule
   String
suffix
    where
          hcsuf :: String
hcsuf      = DynFlags -> String
hcSuf DynFlags
dflags
          odir :: Maybe String
odir       = DynFlags -> Maybe String
objectDir DynFlags
dflags
          osuf :: String
osuf       = DynFlags -> String
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 -> String
myPhaseInputExt Phase
HCc       = String
hcsuf
          myPhaseInputExt Phase
MergeForeign = String
osuf
          myPhaseInputExt Phase
StopLn    = String
osuf
          myPhaseInputExt Phase
other     = Phase -> String
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
_    | Bool
keep_s     -> Bool
True
                       Phase
LlvmOpt | Bool
keep_bc    -> Bool
True
                       Phase
HCc     | Bool
keep_hc    -> Bool
True
                       HsPp HscSource
_  | Bool
keep_hscpp -> Bool
True   -- See #10869
                       Phase
_other               -> Bool
False

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

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

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

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


-- | 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 -> [(String, String)]
llvmOptions DynFlags
dflags =
       [(String
"-enable-tbaa -tbaa",  String
"-enable-tbaa") | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LlvmTBAA DynFlags
dflags ]
    [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
"-relocation-model=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rmodel
        ,String
"-relocation-model=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rmodel) | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rmodel)]
    [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
"-stack-alignment=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
align)
        ,String
"-stack-alignment=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
align)) | Int
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ]

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

  where target :: String
target = PlatformMisc -> String
platformMisc_llvmTarget (PlatformMisc -> String) -> PlatformMisc -> String
forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
        Just (LlvmTarget String
_ String
mcpu [String]
mattr) = String -> [(String, LlvmTarget)] -> Maybe LlvmTarget
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
target (LlvmConfig -> [(String, LlvmTarget)]
llvmTargets (LlvmConfig -> [(String, LlvmTarget)])
-> LlvmConfig -> [(String, LlvmTarget)]
forall a b. (a -> b) -> a -> b
$ DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags)

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

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

        attrs :: String
        attrs :: String
attrs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
mattr
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+sse42"   | DynFlags -> Bool
isSse4_2Enabled DynFlags
dflags   ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+sse2"    | DynFlags -> Bool
isSse2Enabled DynFlags
dflags     ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+sse"     | DynFlags -> Bool
isSseEnabled DynFlags
dflags      ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+avx512f" | DynFlags -> Bool
isAvx512fEnabled DynFlags
dflags  ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+avx2"    | DynFlags -> Bool
isAvx2Enabled DynFlags
dflags     ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+avx"     | DynFlags -> Bool
isAvxEnabled DynFlags
dflags      ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+avx512cd"| DynFlags -> Bool
isAvx512cdEnabled DynFlags
dflags ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+avx512er"| DynFlags -> Bool
isAvx512erEnabled DynFlags
dflags ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+avx512pf"| DynFlags -> Bool
isAvx512pfEnabled DynFlags
dflags ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+bmi"     | DynFlags -> Bool
isBmiEnabled DynFlags
dflags      ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+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 -> String -> DynFlags -> CompPipeline (PhasePlus, String)
runPhase (RealPhase (Unlit HscSource
sf)) String
input_fn DynFlags
dflags
  = do
       String
output_fn <- Phase -> CompPipeline String
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
                     String -> Option
GHC.SysTools.Option     String
"-h"
                     -- See Note [Don't normalise input filenames].
                   , String -> Option
GHC.SysTools.Option (String -> Option) -> String -> Option
forall a b. (a -> b) -> a -> b
$ String -> String
escape String
input_fn
                   , String -> String -> Option
GHC.SysTools.FileOption String
"" String
input_fn
                   , String -> String -> Option
GHC.SysTools.FileOption String
"" String
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 ()
GHC.SysTools.runUnlit DynFlags
dflags [Option]
flags

       (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Cpp HscSource
sf), String
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
       -- GHC.HsToCore.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 :: String -> String
escape (Char
'\\':String
cs) = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
cs
       escape (Char
'\"':String
cs) = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'\"'Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
cs
       escape (Char
'\'':String
cs) = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'\''Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
cs
       escape (Char
c:String
cs)    = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
cs
       escape []        = []

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

runPhase (RealPhase (Cpp HscSource
sf)) String
input_fn DynFlags
dflags0
  = do
       [Located String]
src_opts <- IO [Located String] -> CompPipeline [Located String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located String] -> CompPipeline [Located String])
-> IO [Located String] -> CompPipeline [Located String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> IO [Located String]
getOptionsFromFile DynFlags
dflags0 String
input_fn
       (DynFlags
dflags1, [Located String]
unhandled_flags, [Warn]
warns)
           <- IO (DynFlags, [Located String], [Warn])
-> CompPipeline (DynFlags, [Located String], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located String], [Warn])
 -> CompPipeline (DynFlags, [Located String], [Warn]))
-> IO (DynFlags, [Located String], [Warn])
-> CompPipeline (DynFlags, [Located String], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located String]
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 String] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located String] -> m ()
checkProcessArgsResult DynFlags
dflags1 [Located String]
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, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
HsPp HscSource
sf), String
input_fn)
        else do
            String
output_fn <- Phase -> CompPipeline String
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 -> String -> String -> IO ()
doCpp DynFlags
dflags1 Bool
True{-raw-}
                           String
input_fn String
output_fn
            -- re-read the pragmas now that we've preprocessed the file
            -- See #2464,#3457
            [Located String]
src_opts <- IO [Located String] -> CompPipeline [Located String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located String] -> CompPipeline [Located String])
-> IO [Located String] -> CompPipeline [Located String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> IO [Located String]
getOptionsFromFile DynFlags
dflags0 String
output_fn
            (DynFlags
dflags2, [Located String]
unhandled_flags, [Warn]
warns)
                <- IO (DynFlags, [Located String], [Warn])
-> CompPipeline (DynFlags, [Located String], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located String], [Warn])
 -> CompPipeline (DynFlags, [Located String], [Warn]))
-> IO (DynFlags, [Located String], [Warn])
-> CompPipeline (DynFlags, [Located String], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located String]
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 String] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located String] -> m ()
checkProcessArgsResult DynFlags
dflags2 [Located String]
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, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
HsPp HscSource
sf), String
output_fn)

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

runPhase (RealPhase (HsPp HscSource
sf)) String
input_fn 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, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Hsc HscSource
sf), String
input_fn)
        else do
            PipeEnv{String
src_basename :: String
src_basename :: PipeEnv -> String
src_basename, String
src_suffix :: String
src_suffix :: PipeEnv -> String
src_suffix} <- CompPipeline PipeEnv
getPipeEnv
            let orig_fn :: String
orig_fn = String
src_basename String -> String -> String
<.> String
src_suffix
            String
output_fn <- Phase -> CompPipeline String
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 ()
GHC.SysTools.runPp DynFlags
dflags
                           ( [ String -> Option
GHC.SysTools.Option     String
orig_fn
                             , String -> Option
GHC.SysTools.Option     String
input_fn
                             , String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn
                             ]
                           )

            -- re-read pragmas now that we've parsed the file (see #3674)
            [Located String]
src_opts <- IO [Located String] -> CompPipeline [Located String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located String] -> CompPipeline [Located String])
-> IO [Located String] -> CompPipeline [Located String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> String -> IO [Located String]
getOptionsFromFile DynFlags
dflags String
output_fn
            (DynFlags
dflags1, [Located String]
unhandled_flags, [Warn]
warns)
                <- IO (DynFlags, [Located String], [Warn])
-> CompPipeline (DynFlags, [Located String], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located String], [Warn])
 -> CompPipeline (DynFlags, [Located String], [Warn]))
-> IO (DynFlags, [Located String], [Warn])
-> CompPipeline (DynFlags, [Located String], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
dflags [Located String]
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 String] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located String] -> m ()
checkProcessArgsResult DynFlags
dflags1 [Located String]
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, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Hsc HscSource
sf), String
output_fn)

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

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

        PipeEnv{ stop_phase :: PipeEnv -> Phase
stop_phase=Phase
stop,
                 src_basename :: PipeEnv -> String
src_basename=String
basename,
                 src_suffix :: PipeEnv -> String
src_suffix=String
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 :: String
current_dir = String -> String
takeDirectory String
basename
            new_includes :: IncludeSpecs
new_includes = IncludeSpecs -> [String] -> IncludeSpecs
addImplicitQuoteInclude IncludeSpecs
paths [String
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
        (Maybe InputFileBuffer
hspp_buf,ModuleName
mod_name,[(Maybe FastString, Located ModuleName)]
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 <- String -> IO InputFileBuffer
hGetStringBuffer String
input_fn
            Either
  ErrorMessages
  ([(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)], Located ModuleName)
eimps <- DynFlags
-> InputFileBuffer
-> String
-> String
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
getImports DynFlags
dflags InputFileBuffer
buf String
input_fn (String
basename String -> String -> String
<.> String
suff)
            case Either
  ErrorMessages
  ([(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)], Located ModuleName)
eimps of
              Left 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 ([(Maybe FastString, Located ModuleName)]
src_imps,[(Maybe FastString, Located ModuleName)]
imps,L SrcSpan
_ 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 :: String
o_file = ModLocation -> String
ml_obj_file ModLocation
location -- The real object file
            hi_file :: String
hi_file = ModLocation -> String
ml_hi_file ModLocation
location
            hie_file :: String
hie_file = ModLocation -> String
ml_hie_file ModLocation
location
            dest_file :: String
dest_file | DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags
                            = String
hi_file
                      | Bool
otherwise
                            = String
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
$ String -> IO UTCTime
getModificationUTCTime (String
basename String -> String -> String
<.> String
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 <- String -> UTCTime -> IO Bool
sourceModified String
dest_file UTCTime
src_timestamp
                     Bool
hie_file_mod <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags
                                        then String -> UTCTime -> IO Bool
sourceModified String
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
-> String
-> 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 :: String
ms_hspp_file = String
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 HscEnv
hsc_env p
_ RecompileRequired
what p
_ = HscEnv -> RecompileRequired -> IO ()
oneShotMsg HscEnv
hsc_env RecompileRequired
what
        (HscStatus
result, DynFlags
plugin_dflags) <-
          IO (HscStatus, DynFlags) -> CompPipeline (HscStatus, DynFlags)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HscStatus, DynFlags) -> CompPipeline (HscStatus, DynFlags))
-> IO (HscStatus, DynFlags) -> CompPipeline (HscStatus, DynFlags)
forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, DynFlags)
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 (Int
1,Int
1)

        -- In the rest of the pipeline use the dflags with plugin info
        DynFlags -> CompPipeline ()
setDynFlags DynFlags
plugin_dflags

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

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

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

        case HscStatus
result of
            HscNotGeneratingCode ModIface
_ ModDetails
_ ->
                (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn,
                        String -> String
forall a. String -> a
panic String
"No output filename from Hsc when no-code")
            HscUpToDate ModIface
_ ModDetails
_ ->
                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 -> String -> IO ()
touchObjectFile DynFlags
dflags String
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, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, String
o_file)
            HscUpdateBoot ModIface
_ ModDetails
_ ->
                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 -> String -> IO ()
touchObjectFile DynFlags
dflags String
o_file
                   (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, String
o_file)
            HscUpdateSig ModIface
_ ModDetails
_ ->
                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 :: String
input_fn = String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"runPhase" (ModLocation -> Maybe String
ml_hs_file ModLocation
location)
                       basename :: String
basename = String -> String
dropExtension String
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 -> String -> ModLocation -> ModuleName -> IO ()
compileEmptyStub DynFlags
dflags HscEnv
hsc_env' String
basename ModLocation
location ModuleName
mod_name
                   (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, String
o_file)
            HscRecomp { hscs_guts :: HscStatus -> CgGuts
hscs_guts = CgGuts
cgguts,
                        hscs_mod_location :: HscStatus -> ModLocation
hscs_mod_location = ModLocation
mod_location,
                        hscs_partial_iface :: HscStatus -> PartialModIface
hscs_partial_iface = PartialModIface
partial_iface,
                        hscs_old_iface_hash :: HscStatus -> Maybe Fingerprint
hscs_old_iface_hash = Maybe Fingerprint
mb_old_iface_hash,
                        hscs_iface_dflags :: HscStatus -> DynFlags
hscs_iface_dflags = DynFlags
iface_dflags }
              -> do String
output_fn <- Phase -> CompPipeline String
phaseOutputFilename Phase
next_phase

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

                    (String
outputFilename, Maybe String
mStub, [(ForeignSrcLang, String)]
foreign_files, CgInfos
cg_infos) <- IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
-> CompPipeline
     (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
 -> CompPipeline
      (String, Maybe String, [(ForeignSrcLang, String)], CgInfos))
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
-> CompPipeline
     (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
forall a b. (a -> b) -> a -> b
$
                      HscEnv
-> CgGuts
-> ModLocation
-> String
-> IO (String, Maybe String, [(ForeignSrcLang, String)], CgInfos)
hscGenHardCode HscEnv
hsc_env' CgGuts
cgguts ModLocation
mod_location String
output_fn

                    ModIface
final_iface <- IO ModIface -> CompPipeline ModIface
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
mkFullIface HscEnv
hsc_env'{hsc_dflags :: DynFlags
hsc_dflags=DynFlags
iface_dflags} PartialModIface
partial_iface (CgInfos -> Maybe CgInfos
forall a. a -> Maybe a
Just CgInfos
cg_infos))
                    ModIface -> CompPipeline ()
setIface ModIface
final_iface

                    -- See Note [Writing interface files]
                    let if_dflags :: DynFlags
if_dflags = DynFlags
dflags DynFlags -> GeneralFlag -> DynFlags
`gopt_unset` GeneralFlag
Opt_BuildDynamicToo
                    IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
hscMaybeWriteIface DynFlags
if_dflags ModIface
final_iface Maybe Fingerprint
mb_old_iface_hash ModLocation
mod_location

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

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

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

runPhase (RealPhase Phase
CmmCpp) String
input_fn DynFlags
dflags
  = do String
output_fn <- Phase -> CompPipeline String
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 -> String -> String -> IO ()
doCpp DynFlags
dflags Bool
False{-not raw-}
                      String
input_fn String
output_fn
       (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
Cmm, String
output_fn)

runPhase (RealPhase Phase
Cmm) String
input_fn DynFlags
dflags
  = do let hsc_lang :: HscTarget
hsc_lang = DynFlags -> HscTarget
hscTarget DynFlags
dflags
       let next_phase :: Phase
next_phase = HscSource -> HscTarget -> Phase
hscPostBackendPhase HscSource
HsSrcFile HscTarget
hsc_lang
       String
output_fn <- Phase -> CompPipeline String
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 -> String -> String -> IO ()
hscCompileCmmFile HscEnv
hsc_env String
input_fn String
output_fn
       (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, String
output_fn)

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

runPhase (RealPhase Phase
cc_phase) String
input_fn 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
        [UnitId]
pkgs <- if Bool
hcc then IO [UnitId] -> CompPipeline [UnitId]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [UnitId] -> CompPipeline [UnitId])
-> IO [UnitId] -> CompPipeline [UnitId]
forall a b. (a -> b) -> a -> b
$ String -> IO [UnitId]
getHCFilePackages String
input_fn else [UnitId] -> CompPipeline [UnitId]
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 :)
        [String]
pkg_include_dirs <- IO [String] -> CompPipeline [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> CompPipeline [String])
-> IO [String] -> CompPipeline [String]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [UnitId] -> IO [String]
getUnitIncludePath DynFlags
dflags [UnitId]
pkgs
        let include_paths_global :: [String]
include_paths_global = (String -> [String] -> [String])
-> [String] -> [String] -> [String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ String
x [String]
xs -> (String
"-I" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs) []
              (IncludeSpecs -> [String]
includePathsGlobal IncludeSpecs
cmdline_include_paths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_include_dirs)
        let include_paths_quote :: [String]
include_paths_quote = (String -> [String] -> [String])
-> [String] -> [String] -> [String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ String
x [String]
xs -> (String
"-iquote" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs) []
              (IncludeSpecs -> [String]
includePathsQuote IncludeSpecs
cmdline_include_paths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
               IncludeSpecs -> [String]
includePathsQuoteImplicit IncludeSpecs
cmdline_include_paths)
        let include_paths :: [String]
include_paths = [String]
include_paths_quote [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
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 perform preprocessing and parsing in a single pass,
        -- but it may introduce inconsistency if a different pgm_P is specified.
        let more_preprocessor_opts :: [String]
more_preprocessor_opts = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [String
"-Xpreprocessor", String
i]
              | Bool -> Bool
not Bool
hcc
              , String
i <- DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_P
              ]

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

        let verbFlags :: [String]
verbFlags = DynFlags -> [String]
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.
        [String]
pkg_extra_cc_opts <- IO [String] -> CompPipeline [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> CompPipeline [String])
-> IO [String] -> CompPipeline [String]
forall a b. (a -> b) -> a -> b
$
          if Bool
hcc
             then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
             else DynFlags -> [UnitId] -> IO [String]
getUnitExtraCcOpts DynFlags
dflags [UnitId]
pkgs

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

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

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

        let
          more_hcc_opts :: [String]
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 [ String
"-ffloat-store" ]
                        else []) [String] -> [String] -> [String]
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--.
                [String
"-fno-strict-aliasing"]

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

        IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runCc (Phase -> Maybe ForeignSrcLang
phaseForeignLanguage Phase
cc_phase) DynFlags
dflags (
                        [ String -> String -> Option
GHC.SysTools.FileOption String
"" String
input_fn
                        , String -> Option
GHC.SysTools.Option String
"-o"
                        , String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn
                        ]
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option (
                          [String]
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.
                       [String] -> [String] -> [String]
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
homeUnitId DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
baseUnitId
                                then [ String
"-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
                       [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchSPARC
                           then [String
"-mcpu=v9"]
                           else [])

                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
                       [String] -> [String] -> [String]
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 [String
"-Wimplicit"]
                             else [])

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

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

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

-- This is for calling the assembler on a regular assembly file
runPhase (RealPhase (As Bool
with_cpp)) String
input_fn 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 as_prog :: DynFlags -> [Option] -> IO ()
as_prog | 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 ()
GHC.SysTools.runClang
                    | Bool
otherwise = DynFlags -> [Option] -> IO ()
GHC.SysTools.runAs

        let cmdline_include_paths :: IncludeSpecs
cmdline_include_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags
        let pic_c_flags :: [String]
pic_c_flags = DynFlags -> [String]
picCCOpts DynFlags
dflags

        Phase
next_phase <- CompPipeline Phase
maybeMergeForeign
        String
output_fn <- Phase -> CompPipeline String
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 -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
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 = [ String -> Option
GHC.SysTools.Option (String
"-I" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p)
                              | String
p <- IncludeSpecs -> [String]
includePathsGlobal IncludeSpecs
cmdline_include_paths ]
        let local_includes :: [Option]
local_includes = [ String -> Option
GHC.SysTools.Option (String
"-iquote" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p)
                             | String
p <- IncludeSpecs -> [String]
includePathsQuote IncludeSpecs
cmdline_include_paths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                                IncludeSpecs -> [String]
includePathsQuoteImplicit IncludeSpecs
cmdline_include_paths]
        let runAssembler :: String -> String -> m ()
runAssembler String
inputFilename String
outputFilename
              = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
String -> (String -> m a) -> m a
withAtomicRename String
outputFilename ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
temp_outputFilename -> do
                    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]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
pic_c_flags
                       -- See Note [Produce big objects on Windows]
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
GHC.SysTools.Option String
"-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 [String -> Option
GHC.SysTools.Option String
"-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 [String -> Option
GHC.SysTools.Option String
"-Qunused-arguments"]
                            else [])
                       [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
GHC.SysTools.Option String
"-x"
                          , if Bool
with_cpp
                              then String -> Option
GHC.SysTools.Option String
"assembler-with-cpp"
                              else String -> Option
GHC.SysTools.Option String
"assembler"
                          , String -> Option
GHC.SysTools.Option String
"-c"
                          , String -> String -> Option
GHC.SysTools.FileOption String
"" String
inputFilename
                          , String -> Option
GHC.SysTools.Option String
"-o"
                          , String -> String -> Option
GHC.SysTools.FileOption String
"" String
temp_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 Int
4 (String -> SDoc
text String
"Running the assembler")
        String -> String -> CompPipeline ()
forall {m :: * -> *}. MonadIO m => String -> String -> m ()
runAssembler String
input_fn String
output_fn

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


-----------------------------------------------------------------------------
-- LlvmOpt phase
runPhase (RealPhase Phase
LlvmOpt) String
input_fn DynFlags
dflags
  = do
    String
output_fn <- Phase -> CompPipeline String
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 ()
GHC.SysTools.runLlvmOpt DynFlags
dflags
               (   [Option]
optFlag
                [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
defaultOptions [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++
                [ String -> String -> Option
GHC.SysTools.FileOption String
"" String
input_fn
                , String -> Option
GHC.SysTools.Option String
"-o"
                , String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn]
                )

    (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
LlvmLlc, String
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 Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int
optLevel DynFlags
dflags  -- ensure we're in [0,2]
        llvmOpts :: String
llvmOpts = case Int -> [(Int, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
optIdx ([(Int, String)] -> Maybe String)
-> [(Int, String)] -> Maybe String
forall a b. (a -> b) -> a -> b
$ LlvmConfig -> [(Int, String)]
llvmPasses (LlvmConfig -> [(Int, String)]) -> LlvmConfig -> [(Int, String)]
forall a b. (a -> b) -> a -> b
$ DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags of
                    Just String
passes -> String
passes
                    Maybe String
Nothing -> String -> String
forall a. String -> a
panic (String
"runPhase LlvmOpt: llvm-passes file "
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"is missing passes for level "
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
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 [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> (DynFlags -> [String]) -> [String]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_lo)
                  then (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option ([String] -> [Option]) -> [String] -> [Option]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
llvmOpts
                  else []

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

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

runPhase (RealPhase Phase
LlvmLlc) String
input_fn DynFlags
dflags
  = do
    Phase
next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
                     | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoLlvmMangler DynFlags
dflags -> Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Phase
As Bool
False)
                     | Bool
otherwise -> Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return Phase
LlvmMangle

    String
output_fn <- Phase -> CompPipeline String
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 ()
GHC.SysTools.runLlvmLlc DynFlags
dflags
                (  [Option]
optFlag
                [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
defaultOptions
                [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> String -> Option
GHC.SysTools.FileOption String
"" String
input_fn
                   , String -> Option
GHC.SysTools.Option String
"-o"
                   , String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn
                   ]
                )

    (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, String
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 :: String
llvmOpts = case DynFlags -> Int
optLevel DynFlags
dflags of
      Int
0 -> String
"-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
      Int
1 -> String
"-O1"
      Int
_ -> String
"-O2"

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

    defaultOptions :: [Option]
defaultOptions = (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option ([String] -> [Option])
-> (([String], [String]) -> [String])
-> ([String], [String])
-> [Option]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
words ([String] -> [String])
-> (([String], [String]) -> [String])
-> ([String], [String])
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], [String]) -> [String]
forall a b. (a, b) -> b
snd
                   (([String], [String]) -> [Option])
-> ([String], [String]) -> [Option]
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> ([String], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip (DynFlags -> [(String, String)]
llvmOptions DynFlags
dflags)


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

runPhase (RealPhase Phase
LlvmMangle) String
input_fn DynFlags
dflags
  = do
      let next_phase :: Phase
next_phase = Bool -> Phase
As Bool
False
      String
output_fn <- Phase -> CompPipeline String
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 -> String -> String -> IO ()
llvmFixupAsm DynFlags
dflags String
input_fn String
output_fn
      (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, String
output_fn)

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

runPhase (RealPhase Phase
MergeForeign) String
input_fn DynFlags
dflags
 = do
     PipeState{[String]
foreign_os :: [String]
foreign_os :: PipeState -> [String]
foreign_os} <- CompPipeline PipeState
getPipeState
     String
output_fn <- Phase -> CompPipeline String
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 -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
output_fn)
     if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
foreign_os
       then String -> CompPipeline (PhasePlus, String)
forall a. String -> a
panic String
"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 -> [String] -> String -> IO ()
joinObjectFiles DynFlags
dflags (String
input_fn String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
foreign_os) String
output_fn
         (PhasePlus, String) -> CompPipeline (PhasePlus, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, String
output_fn)

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

maybeMergeForeign :: CompPipeline Phase
maybeMergeForeign :: CompPipeline Phase
maybeMergeForeign
 = do
     PipeState{[String]
foreign_os :: [String]
foreign_os :: PipeState -> [String]
foreign_os} <- CompPipeline PipeState
getPipeState
     if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
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 HscSource
src_flavour ModuleName
mod_name = do
    DynFlags
dflags <- CompPipeline DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    PipeEnv{ src_basename :: PipeEnv -> String
src_basename=String
basename,
             src_suffix :: PipeEnv -> String
src_suffix=String
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 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 String
ml_hs_file = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
basename String -> String -> String
<.> String
suff
        , ml_hi_file :: String
ml_hi_file = ModLocation -> String
ml_hi_file ModLocation
l String -> String -> String
-<.> DynFlags -> String
hiSuf DynFlags
dflags
        , ml_obj_file :: String
ml_obj_file = ModLocation -> String
ml_obj_file ModLocation
l String -> String -> String
-<.> DynFlags -> String
objectSuf DynFlags
dflags
        }
      Maybe ModLocation
_ -> 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 -> String -> String -> IO ModLocation
mkHomeModLocation2 DynFlags
dflags ModuleName
mod_name String
basename String
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 String
ohi = DynFlags -> Maybe String
outputHi DynFlags
dflags
            location3 :: ModLocation
location3 | Just String
fn <- Maybe String
ohi = ModLocation
location2{ ml_hi_file :: String
ml_hi_file = String
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 String
expl_o_file = DynFlags -> Maybe String
outputFile DynFlags
dflags
            location4 :: ModLocation
location4 | Just String
ofile <- Maybe String
expl_o_file
                      , GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
                      = ModLocation
location3 { ml_obj_file :: String
ml_obj_file = String
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 [UnitId]
getHCFilePackages :: String -> IO [UnitId]
getHCFilePackages String
filename =
  IO Handle
-> (Handle -> IO ()) -> (Handle -> IO [UnitId]) -> IO [UnitId]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket (String -> IOMode -> IO Handle
openFile String
filename IOMode
ReadMode) Handle -> IO ()
hClose ((Handle -> IO [UnitId]) -> IO [UnitId])
-> (Handle -> IO [UnitId]) -> IO [UnitId]
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    String
l <- Handle -> IO String
hGetLine Handle
h
    case String
l of
      Char
'/':Char
'*':Char
' ':Char
'G':Char
'H':Char
'C':Char
'_':Char
'P':Char
'A':Char
'C':Char
'K':Char
'A':Char
'G':Char
'E':Char
'S':String
rest ->
          [UnitId] -> IO [UnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> UnitId) -> [String] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map String -> UnitId
stringToUnitId (String -> [String]
words String
rest))
      String
_other ->
          [UnitId] -> IO [UnitId]
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] -> [UnitId] -> IO ()
linkBinary :: DynFlags -> [String] -> [UnitId] -> IO ()
linkBinary = Bool -> DynFlags -> [String] -> [UnitId] -> IO ()
linkBinary' Bool
False

linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary' :: Bool -> DynFlags -> [String] -> [UnitId] -> IO ()
linkBinary' Bool
staticLink DynFlags
dflags [String]
o_files [UnitId]
dep_units = do
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        toolSettings' :: ToolSettings
toolSettings' = DynFlags -> ToolSettings
toolSettings DynFlags
dflags
        verbFlags :: [String]
verbFlags = DynFlags -> [String]
getVerbFlags DynFlags
dflags
        output_fn :: String
output_fn = Bool -> DynFlags -> String
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.

    String
full_output_fn <- if String -> Bool
isAbsolute String
output_fn
                      then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
output_fn
                      else do String
d <- IO String
getCurrentDirectory
                              String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
normalise (String
d String -> String -> String
</> String
output_fn)
    [String]
pkg_lib_paths <- DynFlags -> [UnitId] -> IO [String]
getUnitLibraryPath DynFlags
dflags [UnitId]
dep_units
    let pkg_lib_path_opts :: [String]
pkg_lib_path_opts = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
get_pkg_lib_path_opts [String]
pkg_lib_paths
        get_pkg_lib_path_opts :: String -> [String]
get_pkg_lib_path_opts String
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 -> Set Way -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> Set Way
ways DynFlags
dflags
            = let libpath :: String
libpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
                            then String
"$ORIGIN" String -> String -> String
</>
                                 (String
l String -> String -> String
`makeRelativeTo` String
full_output_fn)
                            else String
l
                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]
                  rpath :: [String]
rpath = if DynFlags -> OS -> Bool
useXLinkerRPath DynFlags
dflags (Platform -> OS
platformOS Platform
platform)
                          then [String
"-Xlinker", String
"-rpath", String
"-Xlinker", String
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 :: [String]
rpathlink = if (Platform -> OS
platformOS Platform
platform) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSSolaris2
                              then []
                              else [String
"-Xlinker", String
"-rpath-link", String
"-Xlinker", String
l]
              in [String
"-L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rpathlink [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
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 -> Set Way -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> Set Way
ways DynFlags
dflags Bool -> Bool -> Bool
&&
           DynFlags -> OS -> Bool
useXLinkerRPath DynFlags
dflags (Platform -> OS
platformOS Platform
platform)
            = let libpath :: String
libpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
                            then String
"@loader_path" String -> String -> String
</>
                                 (String
l String -> String -> String
`makeRelativeTo` String
full_output_fn)
                            else String
l
              in [String
"-L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-Xlinker", String
"-rpath", String
"-Xlinker", String
libpath]
         | Bool
otherwise = [String
"-L" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l]

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

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

    String
extraLinkObj <- DynFlags -> IO String
mkExtraObjToLinkIntoBinary DynFlags
dflags
    [String]
noteLinkObjs <- DynFlags -> [UnitId] -> IO [String]
mkNoteObjsToLinkIntoBinary DynFlags
dflags [UnitId]
dep_units

    let
      ([String]
pre_hs_libs, [String]
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 ([String
"-Wl,-all_load"], [])
              -- OS X does not have a flag to turn off -all_load
            else ([String
"-Wl,--whole-archive"], [String
"-Wl,--no-whole-archive"])
        | Bool
otherwise
        = ([],[])

    [String]
pkg_link_opts <- do
        ([String]
package_hs_libs, [String]
extra_libs, [String]
other_flags) <- DynFlags -> [UnitId] -> IO ([String], [String], [String])
getUnitLinkOpts DynFlags
dflags [UnitId]
dep_units
        [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ if Bool
staticLink
            then [String]
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 [String]
other_flags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
dead_strip
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pre_hs_libs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
package_hs_libs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
post_hs_libs
                  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
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
    [String]
pkg_framework_opts <- DynFlags -> Platform -> [UnitId] -> IO [String]
getUnitFrameworkOpts DynFlags
dflags Platform
platform [UnitId]
dep_units
    let framework_opts :: [String]
framework_opts = DynFlags -> Platform -> [String]
getFrameworkOpts DynFlags
dflags Platform
platform

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

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

    let link :: DynFlags -> [Option] -> IO ()
link DynFlags
dflags [Option]
args | Bool
staticLink = DynFlags -> [Option] -> IO ()
GHC.SysTools.runLibtool DynFlags
dflags [Option]
args
                         | Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
                            = DynFlags -> [Option] -> IO ()
GHC.SysTools.runLink DynFlags
dflags [Option]
args IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DynFlags -> [String] -> String -> IO ()
GHC.SysTools.runInjectRPaths DynFlags
dflags [String]
pkg_lib_paths String
output_fn
                         | Bool
otherwise
                            = DynFlags -> [Option] -> IO ()
GHC.SysTools.runLink DynFlags
dflags [Option]
args

    DynFlags -> [Option] -> IO ()
link DynFlags
dflags (
                       (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
verbFlags
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
GHC.SysTools.Option String
"-o"
                         , String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn
                         ]
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
libmLinkOpts
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option (
                         []

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

                      -- Permit the linker to auto link _symbol to _imp_symbol.
                      -- This lets us link against DLLs without needing an "import library".
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                          then [String
"-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.
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if ToolSettings -> Bool
toolSettings_ldSupportsCompactUnwind ToolSettings
toolSettings' 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
                               Arch
ArchX86 -> Bool
True
                               Arch
ArchX86_64 -> Bool
True
                               ArchARM {} -> Bool
True
                               Arch
ArchAArch64  -> Bool
True
                               Arch
_ -> Bool
False
                          then [String
"-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.
                      [String] -> [String] -> [String]
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 [String
"-Wl,-read_only_relocs,suppress"]
                          else [])

                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if ToolSettings -> Bool
toolSettings_ldIsGnuLd ToolSettings
toolSettings' Bool -> Bool -> Bool
&&
                             Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags)
                          then [String
"-Wl,--gc-sections"]
                          else [])

                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
o_files
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
lib_path_opts)
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
extra_ld_inputs
                      [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option (
                         [String]
rc_objs
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
framework_opts
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_lib_path_opts
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
extraLinkObjString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
noteLinkObjs
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_link_opts
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pkg_framework_opts
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
                          --  dead_strip_dylibs, will remove unused dylibs, and thus save
                          --  space in the load commands. The -headerpad is necessary so
                          --  that we can inject more @rpath's later for the left over
                          --  libraries during runInjectRpaths phase.
                          --
                          --  See Note [Dynamic linking on macOS].
                          then [ String
"-Wl,-dead_strip_dylibs", String
"-Wl,-headerpad,8000" ]
                          else [])
                    ))

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

maybeCreateManifest
   :: DynFlags
   -> FilePath                          -- filename of executable
   -> IO [FilePath]                     -- extra objects to embed, maybe
maybeCreateManifest :: DynFlags -> String -> IO [String]
maybeCreateManifest DynFlags
dflags String
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 :: String
manifest_filename = String
exe_filename String -> String -> String
<.> String
"manifest"

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

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

         String -> String -> IO ()
writeFile String
rc_filename (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
             String
"1 24 MOVEABLE PURE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
manifest_filename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\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
$ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option ([String] -> [Option]) -> [String] -> [Option]
forall a b. (a -> b) -> a -> b
$
               [String
"--input="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
rc_filename,
                String
"--output="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
rc_obj_filename,
                String
"--output-format=coff"]
               -- no FileOptions here: windres doesn't like seeing
               -- backslashes, apparently

         String -> IO ()
removeFile String
manifest_filename

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


linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck DynFlags
dflags [String]
o_files [UnitId]
dep_units
 = 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
          (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
          (String -> SDoc
text String
"Warning: -rtsopts and -with-rtsopts have no effect with -shared." SDoc -> SDoc -> SDoc
$$
           String -> SDoc
text String
"    Call hs_init_ghc() from your main() function to set these options.")

    DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLib DynFlags
dflags [String]
o_files [UnitId]
dep_units

-- | 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] -> [UnitId] -> IO ()
linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO ()
linkStaticLib DynFlags
dflags [String]
o_files [UnitId]
dep_units = do
  let extra_ld_inputs :: [String]
extra_ld_inputs = [ String
f | FileOption String
_ String
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
      modules :: [String]
modules = [String]
o_files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extra_ld_inputs
      output_fn :: String
output_fn = Bool -> DynFlags -> String
exeFileName Bool
True DynFlags
dflags

  String
full_output_fn <- if String -> Bool
isAbsolute String
output_fn
                    then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
output_fn
                    else do String
d <- IO String
getCurrentDirectory
                            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
normalise (String
d String -> String -> String
</> String
output_fn)
  Bool
output_exists <- String -> IO Bool
doesFileExist String
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
$ String -> IO ()
removeFile String
full_output_fn

  [UnitInfo]
pkg_cfgs_init <- DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
dep_units

  let pkg_cfgs :: [UnitInfo]
pkg_cfgs
        | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LinkRts DynFlags
dflags
        = [UnitInfo]
pkg_cfgs_init
        | Bool
otherwise
        = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
rtsUnitId) (UnitId -> Bool) -> (UnitInfo -> UnitId) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId) [UnitInfo]
pkg_cfgs_init

  [String]
archives <- (UnitInfo -> IO [String]) -> [UnitInfo] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (DynFlags -> UnitInfo -> IO [String]
collectArchives DynFlags
dflags) [UnitInfo]
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
<$> (String -> IO ArchiveEntry) -> [String] -> IO [ArchiveEntry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO ArchiveEntry
loadObj [String]
modules)
        IO ([Archive] -> Archive) -> IO [Archive] -> IO Archive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> IO Archive) -> [String] -> IO [Archive]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Archive
loadAr [String]
archives

  if ToolSettings -> Bool
toolSettings_ldIsGnuLd (DynFlags -> ToolSettings
toolSettings DynFlags
dflags)
    then String -> Archive -> IO ()
writeGNUAr String
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 String -> Archive -> IO ()
writeBSDAr String
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 [String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn]

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

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

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

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

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

    let targetArch :: String
targetArch = Arch -> String
stringEncodeArch (Arch -> String) -> Arch -> String
forall a b. (a -> b) -> a -> b
$ Platform -> Arch
platformArch (Platform -> Arch) -> Platform -> Arch
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
        targetOS :: String
targetOS = OS -> String
stringEncodeOS (OS -> String) -> OS -> String
forall a b. (a -> b) -> a -> b
$ Platform -> OS
platformOS (Platform -> OS) -> Platform -> OS
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
        isWindows :: Bool
isWindows = (Platform -> OS
platformOS (Platform -> OS) -> Platform -> OS
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
    let target_defs :: [String]
target_defs =
          [ String
"-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
HOST_OS     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_BUILD_OS",
            String
"-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HOST_ARCH   ++ "_BUILD_ARCH",
            String
"-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetOS    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_HOST_OS",
            String
"-D" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetArch  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_HOST_ARCH" ]
        -- remember, in code we *compile*, the HOST is the same our TARGET,
        -- and BUILD is the same as our HOST.

    let io_manager_defs :: [String]
io_manager_defs =
          [ String
"-D__IO_MANAGER_WINIO__=1" | Bool
isWindows ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
          [ String
"-D__IO_MANAGER_MIO__=1"               ]

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

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

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

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

    -- MIN_VERSION macros
    let state :: UnitState
state = DynFlags -> UnitState
unitState DynFlags
dflags
        uids :: [Unit]
uids = UnitState -> [Unit]
explicitUnits UnitState
state
        pkgs :: [UnitInfo]
pkgs = [Maybe UnitInfo] -> [UnitInfo]
forall a. [Maybe a] -> [a]
catMaybes ((Unit -> Maybe UnitInfo) -> [Unit] -> [Maybe UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
state) [Unit]
uids)
    [Option]
mb_macro_include <-
        if Bool -> Bool
not ([UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
pkgs) Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_VersionMacros DynFlags
dflags
            then do String
macro_stub <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
"h"
                    String -> String -> IO ()
writeFile String
macro_stub ([UnitInfo] -> String
generatePackageVersionMacros [UnitInfo]
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 #10970
                    -- comment 8.
                    [Option] -> IO [Option]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> String -> Option
GHC.SysTools.FileOption String
"-include" String
macro_stub]
            else [Option] -> IO [Option]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    [Option] -> IO ()
cpp_prog       (   (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
verbFlags
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
include_paths
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
hsSourceCppOpts
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
target_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
backend_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
th_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
hscpp_opts
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
sse_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
avx_defs
                    [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
io_manager_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]
++ [ String -> Option
GHC.SysTools.Option     String
"-x"
                       , String -> Option
GHC.SysTools.Option     String
"assembler-with-cpp"
                       , String -> Option
GHC.SysTools.Option     String
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.
                       , String -> Option
GHC.SysTools.Option     String
"-o"
                       , String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn
                       ])

getBackendDefs :: DynFlags -> IO [String]
getBackendDefs :: DynFlags -> IO [String]
getBackendDefs 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
    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ case (LlvmVersion -> [Int]) -> Maybe LlvmVersion -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LlvmVersion -> [Int]
llvmVersionList Maybe LlvmVersion
llvmVer of
               Just [Int
m] -> [ String
"-D__GLASGOW_HASKELL_LLVM__=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
format (Int
m,Int
0) ]
               Just (Int
m:Int
n:[Int]
_) -> [ String
"-D__GLASGOW_HASKELL_LLVM__=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
format (Int
m,Int
n) ]
               Maybe [Int]
_ -> []
  where
    format :: (Int, Int) -> String
format (Int
major, Int
minor)
      | Int
minor Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
100 = String -> String
forall a. HasCallStack => String -> a
error String
"getBackendDefs: Unsupported minor version"
      | Bool
otherwise = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ (Int
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 DynFlags
_ =
    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

generatePackageVersionMacros :: [UnitInfo] -> String
generatePackageVersionMacros :: [UnitInfo] -> String
generatePackageVersionMacros [UnitInfo]
pkgs = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  -- Do not add any C-style comments. See #3389.
  [ String -> String -> Version -> String
generateMacros String
"" String
pkgname Version
version
  | UnitInfo
pkg <- [UnitInfo]
pkgs
  , let version :: Version
version = UnitInfo -> Version
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Version
unitPackageVersion UnitInfo
pkg
        pkgname :: String
pkgname = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar (UnitInfo -> String
forall u. GenUnitInfo u -> String
unitPackageNameString UnitInfo
pkg)
  ]

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

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

 * When assembling (GHC.Driver.Pipeline.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.


Note [Merging object files for GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHCi can usually loads standard linkable object files using GHC's linker
implementation. However, most users build their projects with -split-sections,
meaning that such object files can have an extremely high number of sections.
As the linker must map each of these sections individually, loading such object
files is very inefficient.

To avoid this inefficiency, we use the linker's `-r` flag and a linker script
to produce a merged relocatable object file. This file will contain a singe
text section section and can consequently be mapped far more efficiently. As
gcc tends to do unpredictable things to our linker command line, we opt to
invoke ld directly in this case, in contrast to our usual strategy of linking
via gcc.

-}

joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles :: DynFlags -> [String] -> String -> IO ()
joinObjectFiles DynFlags
dflags [String]
o_files String
output_fn = do
  let toolSettings' :: ToolSettings
toolSettings' = DynFlags -> ToolSettings
toolSettings DynFlags
dflags
      ldIsGnuLd :: Bool
ldIsGnuLd = ToolSettings -> Bool
toolSettings_ldIsGnuLd ToolSettings
toolSettings'
      osInfo :: OS
osInfo = Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
      ld_r :: [Option] -> IO ()
ld_r [Option]
args = DynFlags -> [Option] -> IO ()
GHC.SysTools.runMergeObjects DynFlags
dflags (
                        -- See Note [Produce big objects on Windows]
                        [[Option]] -> [Option]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                          [ [String -> Option
GHC.SysTools.Option String
"--oformat", String -> Option
GHC.SysTools.Option String
"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]
++ (String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
ld_build_id
                     [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ String -> Option
GHC.SysTools.Option String
"-o",
                          String -> String -> Option
GHC.SysTools.FileOption String
"" String
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 :: [String]
ld_build_id | ToolSettings -> Bool
toolSettings_ldSupportsBuildId ToolSettings
toolSettings' = [String
"--build-id=none"]
                  | Bool
otherwise                     = []

  if Bool
ldIsGnuLd
     then do
          String
script <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
"ldscript"
          String
cwd <- IO String
getCurrentDirectory
          let o_files_abs :: [String]
o_files_abs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
cwd String -> String -> String
</> String
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"") [String]
o_files
          String -> String -> IO ()
writeFile String
script (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"INPUT(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
o_files_abs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
          [Option] -> IO ()
ld_r [String -> String -> Option
GHC.SysTools.FileOption String
"" String
script]
     else if ToolSettings -> Bool
toolSettings_ldSupportsFilelist ToolSettings
toolSettings'
     then do
          String
filelist <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
"filelist"
          String -> String -> IO ()
writeFile String
filelist (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
o_files
          [Option] -> IO ()
ld_r [String -> Option
GHC.SysTools.Option String
"-filelist",
                String -> String -> Option
GHC.SysTools.FileOption String
"" String
filelist]
     else do
          [Option] -> IO ()
ld_r ((String -> Option) -> [String] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Option
GHC.SysTools.FileOption String
"") [String]
o_files)

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

writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode 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 :: String -> UTCTime -> IO Bool
sourceModified String
dest_file UTCTime
src_timestamp = do
  Bool
dest_file_exists <- String -> IO Bool
doesFileExist String
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 <- String -> IO UTCTime
getModificationUTCTime String
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 :: HscSource -> HscTarget -> Phase
hscPostBackendPhase :: HscSource -> HscTarget -> Phase
hscPostBackendPhase HscSource
HsBootFile HscTarget
_    =  Phase
StopLn
hscPostBackendPhase HscSource
HsigFile HscTarget
_      =  Phase
StopLn
hscPostBackendPhase HscSource
_ HscTarget
hsc_lang =
  case HscTarget
hsc_lang of
        HscTarget
HscC           -> Phase
HCc
        HscTarget
HscAsm         -> Bool -> Phase
As Bool
False
        HscTarget
HscLlvm        -> Phase
LlvmOpt
        HscTarget
HscNothing     -> Phase
StopLn
        HscTarget
HscInterpreted -> Phase
StopLn

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

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

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