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

{-# 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 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,
   doCpp,
   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
  ) where

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

import GHC.Prelude

import GHC.Platform

import GHC.Tc.Types

import GHC.Driver.Main
import GHC.Driver.Env hiding ( Hsc )
import GHC.Driver.Errors
import GHC.Driver.Pipeline.Monad
import GHC.Driver.Config
import GHC.Driver.Phases
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Driver.Hooks

import GHC.Platform.Ways
import GHC.Platform.ArchOS

import GHC.Parser.Header
import GHC.Parser.Errors.Ppr

import GHC.SysTools
import GHC.Utils.TmpFs

import GHC.Linker.ExtraObj
import GHC.Linker.Dynamic
import GHC.Linker.Static
import GHC.Linker.Types

import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Exception as Exception
import GHC.Utils.Logger

import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList )
import qualified GHC.LanguageExtensions as LangExt
import GHC.Settings

import GHC.Data.Bag            ( unitBag )
import GHC.Data.FastString     ( mkFastString )
import GHC.Data.StringBuffer   ( hGetStringBuffer, hPutStringBuffer )
import GHC.Data.Maybe          ( expectJust )

import GHC.Iface.Make          ( mkFullIface )

import GHC.Types.Basic       ( SuccessFlag(..) )
import GHC.Types.Target
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.SourceError

import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.State
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ)
import GHC.Unit.Module.Deps
import GHC.Unit.Home.ModInfo

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 =
  forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (SourceError -> ErrorMessages
srcErrorMessages SourceError
err))) forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle GhcException -> IO (Either ErrorMessages (DynFlags, String))
handler forall a b. (a -> b) -> a -> b
$
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right 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, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Phase -> PhasePlus
RealPhase Maybe Phase
mb_phase)
        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)
        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)
  forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags, String
fp)
  where
    srcspan :: SrcSpan
srcspan = SrcLoc -> SrcSpan
srcLocSpan 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 (DynFlags, String))
handler (ProgramError String
msg) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$
        SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
srcspan forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
msg
    handler GhcException
ex = 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' forall a. Maybe a
Nothing (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

   let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env0
   let tmpfs :: TmpFs
tmpfs  = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env0
   Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger 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, HscEnv
plugin_hsc_env) <- Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, HscEnv)
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)
   -- Use an HscEnv updated with the plugin info
   let hsc_env' :: HscEnv
hsc_env' = HscEnv
plugin_hsc_env

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

   case (HscStatus
status, Backend
bcknd) of
        (HscUpToDate ModIface
iface ModDetails
hmi_details, Backend
_) ->
            -- TODO recomp014 triggers this assert. What's going on?!
            -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )
            forall (m :: * -> *) a. Monad m => a -> m a
return 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, Backend
NoBackend) ->
            let mb_linkable :: Maybe Linkable
mb_linkable = if HscSource -> Bool
isHsBootOrSig HscSource
src_flavour
                                then forall a. Maybe a
Nothing
                                -- TODO: Questionable.
                                else forall a. a -> Maybe a
Just (UTCTime -> Module -> [Unlinked] -> Linkable
LM (ModSummary -> UTCTime
ms_hs_date ModSummary
summary) Module
this_mod [])
            in forall (m :: * -> *) a. Monad m => a -> m a
return 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
_, Backend
_) -> forall a. String -> a
panic String
"compileOne HscNotGeneratingCode"
        (HscStatus
_, Backend
NoBackend) -> forall a. String -> a
panic String
"compileOne NoBackend"
        (HscUpdateBoot ModIface
iface ModDetails
hmi_details, Backend
Interpreter) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details forall a. Maybe a
Nothing
        (HscUpdateBoot ModIface
iface ModDetails
hmi_details, Backend
_) -> do
            Logger -> DynFlags -> String -> IO ()
touchObjectFile Logger
logger DynFlags
dflags String
object_filename
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details forall a. Maybe a
Nothing
        (HscUpdateSig ModIface
iface ModDetails
hmi_details, Backend
Interpreter) -> do
            let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM (ModSummary -> UTCTime
ms_hs_date ModSummary
summary) Module
this_mod []
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details (forall a. a -> Maybe a
Just Linkable
linkable)
        (HscUpdateSig ModIface
iface ModDetails
hmi_details, Backend
_) -> do
            String
output_fn <- Logger
-> TmpFs
-> Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Logger
logger TmpFs
tmpfs Phase
next_phase
                            (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule) String
basename DynFlags
dflags
                            Phase
next_phase (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,
                               forall a. Maybe a
Nothing,
                               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)))
                              (forall a. a -> Maybe a
Just String
basename)
                              PipelineOutput
Persistent
                              (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]
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details (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
                   }, Backend
Interpreter) -> do
            -- In interpreted mode the regular codeGen backend is not run so we
            -- generate a interface without codeGen info.
            ModIface
final_iface <- HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
mkFullIface HscEnv
hsc_env' PartialModIface
partial_iface forall a. Maybe a
Nothing
            -- Reconstruct the `ModDetails` from the just-constructed `ModIface`
            -- See Note [ModDetails and --make mode]
            ModDetails
hmi_details <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails HscEnv
hsc_env' ModSummary
summary ModIface
final_iface
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface Logger
logger DynFlags
dflags Bool
True 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 -> 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
                          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 forall a. [a] -> [a] -> [a]
++ [Unlinked]
stub_o)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
final_iface ModDetails
hmi_details (forall a. a -> Maybe a
Just Linkable
linkable)
        (HscRecomp{}, Backend
_) -> do
            String
output_fn <- Logger
-> TmpFs
-> Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Logger
logger TmpFs
tmpfs Phase
next_phase
                            (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule)
                            String
basename DynFlags
dflags Phase
next_phase (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,
                               forall a. Maybe a
Nothing,
                               forall a. a -> Maybe a
Just (HscSource -> ModuleName -> HscStatus -> PhasePlus
HscOut HscSource
src_flavour ModuleName
mod_name HscStatus
status))
                              (forall a. a -> Maybe a
Just String
basename)
                              PipelineOutput
Persistent
                              (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
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details (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    = 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    = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Way
WayDyn) (DynFlags -> Ways
ways DynFlags
dflags0)
       isProfWay :: Bool
isProfWay   = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Way
WayProf) (DynFlags -> Ways
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 -> Backend -> Phase
hscPostBackendPhase HscSource
src_flavour Backend
bcknd
       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
       loadAsByteCode :: Bool
loadAsByteCode
         | Just (Target TargetId
_ Bool
obj Maybe (InputFileBuffer, UTCTime)
_) <- ModSummary -> [Target] -> Maybe Target
findTarget ModSummary
summary (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env0)
         , Bool -> Bool
not Bool
obj
         = Bool
True
         | Bool
otherwise = Bool
False
       -- Figure out which backend we're using
       (Backend
bcknd, DynFlags
dflags3)
         -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags
         -- suggest to generate object code (which may happen in case -fobject-code
         -- was set), force it to generate byte-code. This is NOT transitive and
         -- only applies to direct targets.
         | Bool
loadAsByteCode
         = (Backend
Interpreter, DynFlags
dflags2 { backend :: Backend
backend = Backend
Interpreter })
         | Bool
otherwise
         = (DynFlags -> Backend
backend DynFlags
dflags, DynFlags
dflags2)
       dflags :: DynFlags
dflags  = DynFlags
dflags3 { includePaths :: IncludeSpecs
includePaths = IncludeSpecs -> [String] -> IncludeSpecs
addImplicitQuoteInclude IncludeSpecs
old_paths [String
current_dir] }
       hsc_env :: HscEnv
hsc_env = HscEnv
hsc_env0 {hsc_dflags :: DynFlags
hsc_dflags = 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
         -- #8042: Usually pre-compiled code is preferred to be loaded in ghci
         -- if available. So, if the "*" prefix was used, force recompilation
         -- to make sure byte-code is loaded.
         | Bool
force_recomp Bool -> Bool -> Bool
|| Bool
loadAsByteCode = SourceModified
SourceModified
         | Bool
otherwise = SourceModified
source_modified0

       always_do_basic_recompilation_check :: Bool
always_do_basic_recompilation_check = case Backend
bcknd of
                                             Backend
Interpreter -> Bool
True
                                             Backend
_ -> 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 = 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, forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just (Phase -> PhasePlus
RealPhase Phase
phase))
                       forall a. Maybe a
Nothing (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_GhcSession)
                       forall a. Maybe a
Nothing{-no ModLocation-}
                       []
        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
  let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
  let tmpfs :: TmpFs
tmpfs  = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
  String
empty_stub <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
"c"
  let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
      src :: SDoc
src = String -> SDoc
text String
"int" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"= 0;"
  String -> String -> IO ()
writeFile String
empty_stub (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LabelStyle -> SDoc -> SDoc
pprCode LabelStyle
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, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
                  (forall a. a -> Maybe a
Just String
basename)
                  PipelineOutput
Persistent
                  (forall a. a -> Maybe a
Just ModLocation
location)
                  []
  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
     -> Logger                  -- ^ Logger
     -> TmpFs
     -> Hooks
     -> DynFlags                -- ^ dynamic flags
     -> UnitEnv                 -- ^ unit environment
     -> 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
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link GhcLink
ghcLink Logger
logger TmpFs
tmpfs Hooks
hooks DynFlags
dflags UnitEnv
unit_env Bool
batch_attempt_linking HomePackageTable
hpt =
  case Hooks
-> Maybe
     (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
linkHook Hooks
hooks of
      Maybe
  (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
Nothing -> case GhcLink
ghcLink of
          GhcLink
NoLink        -> forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
          GhcLink
LinkBinary    -> Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link' Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env Bool
batch_attempt_linking HomePackageTable
hpt
          GhcLink
LinkStaticLib -> Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link' Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env Bool
batch_attempt_linking HomePackageTable
hpt
          GhcLink
LinkDynLib    -> Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link' Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env Bool
batch_attempt_linking HomePackageTable
hpt
          GhcLink
LinkInMemory
              | PlatformMisc -> Bool
platformMisc_ghcWithInterpreter forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
              -> -- Not Linking...(demand linker will do the job)
                 forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
              | Bool
otherwise
              -> forall a. GhcLink -> a
panicBadLink GhcLink
LinkInMemory
      Just GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
h  -> GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
h GhcLink
ghcLink DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt


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

link' :: Logger
      -> TmpFs
      -> DynFlags                -- ^ dynamic flags
      -> UnitEnv                 -- ^ unit environment
      -> Bool                    -- ^ attempt linking in batch mode?
      -> HomePackageTable        -- ^ what to link
      -> IO SuccessFlag

link' :: Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link' Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env 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  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(UnitId, Bool)]
dep_pkgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"link"forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> Maybe Linkable
hm_linkable) [HomeModInfo]
home_mod_infos

        Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
3 (String -> SDoc
text String
"link: linkables are ..." SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map 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 Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
3 (String -> SDoc
text String
"link(batch): linking omitted (-c flag given).")
                  forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
          else do

        let getOfiles :: Linkable -> [String]
getOfiles (LM UTCTime
_ Module
_ [Unlinked]
us) = forall a b. (a -> b) -> [a] -> [b]
map Unlinked -> String
nameOfObject (forall a. (a -> Bool) -> [a] -> [a]
filter Unlinked -> Bool
isObject [Unlinked]
us)
            obj_files :: [String]
obj_files = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Linkable -> [String]
getOfiles [Linkable]
linkables
            platform :: Platform
platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
            exe_file :: String
exe_file  = Platform -> Bool -> Maybe String -> String
exeFileName Platform
platform Bool
staticLink (DynFlags -> Maybe String
outputFile DynFlags
dflags)

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

        Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg Logger
logger DynFlags
dflags (String -> SDoc
text String
"Linking " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
exe_file SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" ...")

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

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

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

   | Bool
otherwise
   = do Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger 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.")
        forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded


linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded :: Logger
-> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded Logger
logger DynFlags
dflags UnitEnv
unit_env 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 platform :: Platform
platform   = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
      unit_state :: UnitState
unit_state = UnitEnv -> UnitState
ue_units UnitEnv
unit_env
      exe_file :: String
exe_file   = Platform -> Bool -> Maybe String -> String
exeFileName Platform
platform Bool
staticLink (DynFlags -> Maybe String
outputFile DynFlags
dflags)
  Either IOException UTCTime
e_exe_time <- forall a. IO a -> IO (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getModificationUTCTime String
exe_file
  case Either IOException UTCTime
e_exe_time of
    Left IOException
_  -> 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. IO a -> IO (Either IOException a)
tryIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO UTCTime
getModificationUTCTime) [String]
extra_ld_inputs
        let ([IOException]
errs,[UTCTime]
extra_times) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either IOException UTCTime]
e_extra_times
        let obj_times :: [UTCTime]
obj_times =  forall a b. (a -> b) -> [a] -> [b]
map Linkable -> UTCTime
linkableTime [Linkable]
linkables forall a. [a] -> [a] -> [a]
++ [UTCTime]
extra_times
        if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IOException]
errs) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UTCTime
t forall a. Ord a => a -> a -> Bool
<) [UTCTime]
obj_times
            then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else do

        -- next, check libraries. XXX this only checks Haskell libraries,
        -- not extra_libraries or -l things from the command line.
        let pkg_hslibs :: [([String], String)]
pkg_hslibs  = [ (Ways -> [UnitInfo] -> [String]
collectLibraryDirs (DynFlags -> Ways
ways DynFlags
dflags) [UnitInfo
c], String
lib)
                          | Just UnitInfo
c <- forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
unit_state) [UnitId]
pkg_deps,
                            String
lib <- GhcNameVersion -> Ways -> UnitInfo -> [String]
unitHsLibs (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Ways
ways DynFlags
dflags) UnitInfo
c ]

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

findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)
findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe String)
findHSLib Platform
platform Ways
ws [String]
dirs String
lib = do
  let batch_lib_file :: String
batch_lib_file = if Way
WayDyn forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Ways
ws
                      then String
"lib" forall a. [a] -> [a] -> [a]
++ String
lib String -> String -> String
<.> String
"a"
                      else Platform -> String -> String
platformSOName Platform
platform String
lib
  [String]
found <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist (forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
</> String
batch_lib_file) [String]
dirs)
  case [String]
found of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    (String
x:[String]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- 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
  HscEnv -> Phase -> [String] -> IO ()
doLink 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
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
exists) forall a b. (a -> b) -> a -> b
$
        forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
CmdLineError (String
"does not exist: " 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.
         | Backend
NoBackend <- DynFlags -> Backend
backend 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
         | 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, forall a. Maybe a
Nothing, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Phase -> PhasePlus
RealPhase Maybe Phase
mb_phase)
                            forall a. Maybe a
Nothing
                            PipelineOutput
output
                            forall a. Maybe a
Nothing{-no ModLocation-} []
   forall (m :: * -> *) a. Monad m => a -> m a
return String
out_file


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

  | Bool
otherwise
  = let
        dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags   HscEnv
hsc_env
        logger :: Logger
logger   = HscEnv -> Logger
hsc_logger   HscEnv
hsc_env
        unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
        tmpfs :: TmpFs
tmpfs    = HscEnv -> TmpFs
hsc_tmpfs    HscEnv
hsc_env
    in case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
        GhcLink
NoLink        -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        GhcLink
LinkBinary    -> Logger
-> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkBinary         Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [String]
o_files []
        GhcLink
LinkStaticLib -> Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkStaticLib      Logger
logger       DynFlags
dflags UnitEnv
unit_env [String]
o_files []
        GhcLink
LinkDynLib    -> Logger
-> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkDynLibCheck    Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [String]
o_files []
        GhcLink
other         -> 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 = forall a. a -> Maybe a
Just (String
basename forall a. [a] -> [a] -> [a]
++ String
".") }
             hsc_env :: HscEnv
hsc_env = HscEnv
hsc_env0 {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags}
             logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
             tmpfs :: TmpFs
tmpfs  = HscEnv -> TmpFs
hsc_tmpfs  HscEnv
hsc_env

             (String
input_basename, String
suffix) = String -> (String, String)
splitExtension String
input_fn
             suffix' :: String
suffix' = 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 = 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
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 }

         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
isBackpackishSuffix String
suffix') forall a b. (a -> b) -> a -> b
$
           forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
UsageError
                       (String
"use --backpack to process " 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')
                 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)) forall a b. (a -> b) -> a -> b
$
                       forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
UsageError
                                   (String
"cannot compile this file to desired target: "
                                      forall a. [a] -> [a] -> [a]
++ String
input_fn))
             HscOut {} -> 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 <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs 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 forall a b. (a -> b) -> a -> b
$ String
"{-# LINE 1 \""forall a. [a] -> [a] -> [a]
++ String
input_fn forall a. [a] -> [a] -> [a]
++ String
"\"#-}"
                 Handle -> InputFileBuffer -> IO ()
hPutStringBuffer Handle
hdl InputFileBuffer
input_buf
                 Handle -> IO ()
hClose Handle
hdl
                 forall (m :: * -> *) a. Monad m => a -> m a
return String
fn
             (PhasePlus
_, Maybe InputFileBuffer
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return String
input_fn

         Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger 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

         let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHaskellishFile forall a b. (a -> b) -> a -> b
$
           forall (m :: * -> *). MonadIO m => DynFlags -> m DynamicTooState
dynamicTooState DynFlags
dflags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
               DynamicTooState
DT_Dont   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
               DynamicTooState
DT_Dyn    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
               DynamicTooState
DT_OK     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
               -- If we are compiling a Haskell module with -dynamic-too, we
               -- first try the "fast path": that is we compile the non-dynamic
               -- version and at the same time we check that interfaces depended
               -- on exist both for the non-dynamic AND the dynamic way. We also
               -- check that they have the same hash.
               --    If they don't, dynamicTooState is set to DT_Failed.
               --       See GHC.Iface.Load.checkBuildDynamicToo
               --    If they do, in the end we produce both the non-dynamic and
               --    dynamic outputs.
               --
               -- If this "fast path" failed, we execute the whole pipeline
               -- again, this time for the dynamic way *only*. To do that we
               -- just set the dynamicNow bit from the start to ensure that the
               -- dynamic DynFlags fields are used and we disable -dynamic-too
               -- (its state is already set to DT_Failed so it wouldn't do much
               -- anyway).
               DynamicTooState
DT_Failed
                   -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
                   | OS
OSMinGW32 <- Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   | Bool
otherwise -> do
                       Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
4
                           (String -> SDoc
text String
"Running the full pipeline again for -dynamic-too")
                       let dflags0 :: DynFlags
dflags0 = forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> GeneralFlag -> DynFlags
gopt_unset GeneralFlag
Opt_BuildDynamicToo
                                      forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setDynamicNow
                                      forall a b. (a -> b) -> a -> b
$ DynFlags
dflags
                       HscEnv
hsc_env' <- DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags0
                       ([UnitDatabase UnitId]
dbs,UnitState
unit_state,HomeUnit
home_unit,Maybe PlatformConstants
mconstants) <- Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> IO
     ([UnitDatabase UnitId], UnitState, HomeUnit,
      Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags0 forall a. Maybe a
Nothing
                       DynFlags
dflags1 <- DynFlags -> Maybe PlatformConstants -> IO DynFlags
updatePlatformConstants DynFlags
dflags0 Maybe PlatformConstants
mconstants
                       let unit_env :: UnitEnv
unit_env = UnitEnv
                             { ue_platform :: Platform
ue_platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags1
                             , ue_namever :: GhcNameVersion
ue_namever   = DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags1
                             , ue_home_unit :: HomeUnit
ue_home_unit = HomeUnit
home_unit
                             , ue_units :: UnitState
ue_units     = UnitState
unit_state
                             }
                       let hsc_env'' :: HscEnv
hsc_env'' = HscEnv
hsc_env'
                            { hsc_dflags :: DynFlags
hsc_dflags   = DynFlags
dflags1
                            , hsc_unit_env :: UnitEnv
hsc_unit_env = UnitEnv
unit_env
                            , hsc_unit_dbs :: Maybe [UnitDatabase UnitId]
hsc_unit_dbs = forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs
                            }
                       (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
                       forall (m :: * -> *) a. Monad m => a -> m a
return ()
         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
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 = forall a. Maybe a
Nothing }
  (PipeState
pipe_state, String
fp) <- 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
  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 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
  -- 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
_ ->
            forall (m :: * -> *) a. Monad m => a -> m a
return String
input_fn
        PipelineOutput
output ->
            do PipeState
pst <- CompPipeline PipeState
getPipeState
               TmpFs
tmpfs <- HscEnv -> TmpFs
hsc_tmpfs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompPipeline HscEnv
getPipeSession
               String
final_fn <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> TmpFs
-> Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Logger
logger TmpFs
tmpfs
                                        Phase
stopPhase PipelineOutput
output (PipeEnv -> String
src_basename PipeEnv
env)
                                        DynFlags
dflags Phase
stopPhase (PipeState -> Maybe ModLocation
maybe_loc PipeState
pst)
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
final_fn forall a. Eq a => a -> a -> Bool
/= String
input_fn) forall a b. (a -> b) -> a -> b
$ do
                  let msg :: String
msg = (String
"Copying `" forall a. [a] -> [a] -> [a]
++ String
input_fn forall a. [a] -> [a] -> [a]
++String
"' to `" forall a. [a] -> [a] -> [a]
++ String
final_fn forall a. [a] -> [a] -> [a]
++ String
"'")
                      line_prag :: Maybe String
line_prag = forall a. a -> Maybe a
Just (String
"{-# LINE 1 \"" forall a. [a] -> [a] -> [a]
++ PipeEnv -> String
src_filename PipeEnv
env forall a. [a] -> [a] -> [a]
++ String
"\" #-}\n")
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> String -> Maybe String -> String -> String -> IO ()
copyWithHeader Logger
logger DynFlags
dflags String
msg Maybe String
line_prag String
input_fn String
final_fn
               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 #-}.
     -> forall a. String -> a
panic (String
"pipeLoop: at phase " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Phase
realPhase forall a. [a] -> [a] -> [a]
++
           String
" but I wanted to stop at phase " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Phase
stopPhase)

   PhasePlus
_
     -> do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
4
                                  (String -> SDoc
text String
"Running phase" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr PhasePlus
phase)

           case PhasePlus
phase of
               HscOut {} -> do
                   -- Depending on the dynamic-too state, we first run the
                   -- backend to generate the non-dynamic objects and then
                   -- re-run it to generate the dynamic ones.
                   let noDynToo :: CompPipeline String
noDynToo = do
                        (PhasePlus
next_phase, String
output_fn) <- PhasePlus -> String -> CompPipeline (PhasePlus, String)
runHookedPhase PhasePlus
phase String
input_fn
                        PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
next_phase String
output_fn
                   let dynToo :: CompPipeline String
dynToo = do
                          -- we must run the non-dynamic way before the dynamic
                          -- one because there may be interfaces loaded only in
                          -- the backend (e.g., in CorePrep). See #19264
                          String
r <- CompPipeline String
noDynToo

                          -- we must check the dynamic-too state again, because
                          -- we may have failed to load a dynamic interface in
                          -- the backend.
                          forall (m :: * -> *). MonadIO m => DynFlags -> m DynamicTooState
dynamicTooState DynFlags
dflags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                            DynamicTooState
DT_OK -> do
                                let dflags' :: DynFlags
dflags' = DynFlags -> DynFlags
setDynamicNow DynFlags
dflags -- set "dynamicNow"
                                DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags'
                                (PhasePlus
next_phase, String
output_fn) <- PhasePlus -> String -> CompPipeline (PhasePlus, String)
runHookedPhase PhasePlus
phase String
input_fn
                                String
_ <- PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
next_phase String
output_fn
                                -- TODO: we probably shouldn't ignore the result of
                                -- the dynamic compilation
                                DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags -- restore flags without "dynamicNow" set
                                forall (m :: * -> *) a. Monad m => a -> m a
return String
r
                            DynamicTooState
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
r

                   forall (m :: * -> *). MonadIO m => DynFlags -> m DynamicTooState
dynamicTooState DynFlags
dflags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                     DynamicTooState
DT_Dont   -> CompPipeline String
noDynToo
                     DynamicTooState
DT_Failed -> CompPipeline String
noDynToo
                     DynamicTooState
DT_OK     -> CompPipeline String
dynToo
                     DynamicTooState
DT_Dyn    -> CompPipeline String
noDynToo
                        -- it shouldn't be possible to be in this last case
                        -- here. It would mean that we executed the whole
                        -- pipeline with DynamicNow and Opt_BuildDynamicToo set.
                        --
                        -- When we restart the whole pipeline for -dynamic-too
                        -- we set DynamicNow but we unset Opt_BuildDynamicToo so
                        -- it's weird.
               PhasePlus
_ -> do
                  (PhasePlus
next_phase, String
output_fn) <- PhasePlus -> String -> CompPipeline (PhasePlus, String)
runHookedPhase PhasePlus
phase String
input_fn
                  PhasePlus -> String -> CompPipeline String
pipeLoop PhasePlus
next_phase String
output_fn

runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)
runHookedPhase :: PhasePlus -> String -> CompPipeline (PhasePlus, String)
runHookedPhase PhasePlus
pp String
input = do
  Hooks
hooks <- HscEnv -> Hooks
hsc_hooks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompPipeline HscEnv
getPipeSession
  case Hooks
-> Maybe (PhasePlus -> String -> CompPipeline (PhasePlus, String))
runPhaseHook Hooks
hooks of
    Maybe (PhasePlus -> String -> CompPipeline (PhasePlus, String))
Nothing -> PhasePlus -> String -> CompPipeline (PhasePlus, String)
runPhase PhasePlus
pp String
input
    Just PhasePlus -> String -> CompPipeline (PhasePlus, String)
h  -> PhasePlus -> String -> CompPipeline (PhasePlus, String)
h PhasePlus
pp String
input

-- -----------------------------------------------------------------------------
-- 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
  DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
  let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> TmpFs
-> Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Logger
logger TmpFs
tmpfs 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
  :: Logger
  -> TmpFs
  -> Phase
  -> PipelineOutput
  -> String
  -> DynFlags
  -> Phase -- next phase
  -> Maybe ModLocation
  -> IO FilePath
getOutputFilename :: Logger
-> TmpFs
-> Phase
-> PipelineOutput
-> String
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO String
getOutputFilename Logger
logger TmpFs
tmpfs 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return String
f
                                           Maybe String
Nothing ->
                                               forall a. String -> a
panic String
"SpecificFile: No filename"
 | Bool
keep_this_output                      = IO String
persistent_fn
 | Temporary TempFileLifetime
lifetime <- PipelineOutput
output          = Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
lifetime String
suffix
 | Bool
otherwise                             = Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs 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 = forall (m :: * -> *) a. Monad m => a -> m a
return String
odir_persistent
             | Bool
otherwise            = 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 ]
    forall a. [a] -> [a] -> [a]
++ [(String
"-relocation-model=" forall a. [a] -> [a] -> [a]
++ String
rmodel
        ,String
"-relocation-model=" forall a. [a] -> [a] -> [a]
++ String
rmodel) | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rmodel)]
    forall a. [a] -> [a] -> [a]
++ [(String
"-stack-alignment=" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Int
align)
        ,String
"-stack-alignment=" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Int
align)) | Int
align forall a. Ord a => a -> a -> Bool
> Int
0 ]

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

  where target :: String
target = PlatformMisc -> String
platformMisc_llvmTarget forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
        Just (LlvmTarget String
_ String
mcpu [String]
mattr) = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
target (LlvmConfig -> [(String, LlvmTarget)]
llvmTargets 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> Ways
ways DynFlags
dflags  = String
"dynamic-no-pic"
               | Bool
otherwise                  = String
"static"

        platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

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

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

        abi :: String
        abi :: String
abi = case Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
                Arch
ArchRISCV64 -> String
"lp64d"
                Arch
_           -> String
""

-- -----------------------------------------------------------------------------
-- | 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
         -> 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 -> CompPipeline (PhasePlus, String)
runPhase (RealPhase (Unlit HscSource
sf)) String
input_fn = do
    let
       -- 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
'\\'forall a. a -> [a] -> [a]
:Char
'\\'forall a. a -> [a] -> [a]
: String -> String
escape String
cs
       escape (Char
'\"':String
cs) = Char
'\\'forall a. a -> [a] -> [a]
:Char
'\"'forall a. a -> [a] -> [a]
: String -> String
escape String
cs
       escape (Char
'\'':String
cs) = Char
'\\'forall a. a -> [a] -> [a]
:Char
'\''forall a. a -> [a] -> [a]
: String -> String
escape String
cs
       escape (Char
c:String
cs)    = Char
c forall a. a -> [a] -> [a]
: String -> String
escape String
cs
       escape []        = []

    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 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
                ]

    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runUnlit Logger
logger DynFlags
dflags [Option]
flags

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

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

runPhase (RealPhase (Cpp HscSource
sf)) String
input_fn
  = do
       DynFlags
dflags0 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
       [Located String]
src_opts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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)
           <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located String]
src_opts
       DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags1
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Located String] -> m ()
checkProcessArgsResult [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.
           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags1) forall a b. (a -> b) -> a -> b
$
               forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DynFlags
dflags1 [Warn]
warns

           -- no need to preprocess CPP, just pass input file along
           -- to the next phase of the pipeline.
           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)
            HscEnv
hsc_env <- CompPipeline HscEnv
getPipeSession
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> String
-> String
-> IO ()
doCpp Logger
logger
                           (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
                           (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                           (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
                           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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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)
                <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located String]
src_opts
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Located String] -> m ()
checkProcessArgsResult [Located String]
unhandled_flags
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags2) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DynFlags
dflags2 [Warn]
warns
            -- the HsPp pass below will emit warnings

            DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags2

            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 = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    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.
       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)
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runPp Logger
logger 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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)
            <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
dflags [Located String]
src_opts
        DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags1
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Located String] -> m ()
checkProcessArgsResult [Located String]
unhandled_flags
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DynFlags
dflags1 [Warn]
warns

        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
 = do   -- normal Hsc mode, not mkdependHS
        DynFlags
dflags0 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

        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) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            InputFileBuffer
buf <- String -> IO InputFileBuffer
hGetStringBuffer String
input_fn
            let imp_prelude :: Bool
imp_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
dflags
                popts :: ParserOpts
popts = DynFlags -> ParserOpts
initParserOpts DynFlags
dflags
            Either
  (Bag PsError)
  ([(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)], Located ModuleName)
eimps <- ParserOpts
-> Bool
-> InputFileBuffer
-> String
-> String
-> IO
     (Either
        (Bag PsError)
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
getImports ParserOpts
popts Bool
imp_prelude InputFileBuffer
buf String
input_fn (String
basename String -> String -> String
<.> String
suff)
            case Either
  (Bag PsError)
  ([(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)], Located ModuleName)
eimps of
              Left Bag PsError
errs -> forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError Bag PsError
errs)
              Right ([(Maybe FastString, Located ModuleName)]
src_imps,[(Maybe FastString, Located ModuleName)]
imps,L SrcSpan
_ ModuleName
mod_name) -> forall (m :: * -> *) a. Monad m => a -> m a
return
                  (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getModificationUTCTime (String
basename String -> String -> String
<.> String
suff)

        SourceModified
source_unchanged <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                     if Bool
dest_file_mod Bool -> Bool -> Bool
|| Bool
hie_file_mod
                        then forall (m :: * -> *) a. Monad m => a -> m a
return SourceModified
SourceModified
                        else 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 {  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  = forall a. Maybe a
Nothing,
                                        ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod   = forall a. Maybe a
Nothing,
                                        ms_iface_date :: Maybe UTCTime
ms_iface_date   = forall a. Maybe a
Nothing,
                                        ms_hie_date :: Maybe UTCTime
ms_hie_date     = 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, HscEnv
plugin_hsc_env) <-
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, HscEnv)
hscIncrementalCompile Bool
True forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall {p} {p}. HscEnv -> p -> RecompileRequired -> p -> IO ()
msg) HscEnv
hsc_env'
                            ModSummary
mod_summary SourceModified
source_unchanged forall a. Maybe a
Nothing (Int
1,Int
1)

        -- In the rest of the pipeline use the loaded plugins
        [LoadedPlugin] -> [StaticPlugin] -> CompPipeline ()
setPlugins (HscEnv -> [LoadedPlugin]
hsc_plugins        HscEnv
plugin_hsc_env)
                   (HscEnv -> [StaticPlugin]
hsc_static_plugins HscEnv
plugin_hsc_env)
        -- "driver" plugins may have modified the DynFlags so we update them
        DynFlags -> CompPipeline ()
setDynFlags (HscEnv -> DynFlags
hsc_dflags HscEnv
plugin_hsc_env)

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

runPhase (HscOut HscSource
src_flavour ModuleName
mod_name HscStatus
result) String
_ = do
        DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
        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
            next_phase :: Phase
next_phase = HscSource -> Backend -> Phase
hscPostBackendPhase HscSource
src_flavour (DynFlags -> Backend
backend DynFlags
dflags)

        case HscStatus
result of
            HscNotGeneratingCode ModIface
_ ModDetails
_ ->
                forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn,
                        forall a. String -> a
panic String
"No output filename from Hsc when no-code")
            HscUpToDate ModIface
_ ModDetails
_ ->
                do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> String -> IO ()
touchObjectFile Logger
logger 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).
                   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
                   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> String -> IO ()
touchObjectFile Logger
logger DynFlags
dflags String
o_file
                   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 = 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
                   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
                   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
                      }
              -> 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) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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

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

                    -- See Note [Writing interface files]
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface Logger
logger DynFlags
dflags Bool
False ModIface
final_iface Maybe Fingerprint
mb_old_iface_hash ModLocation
mod_location

                    Maybe String
stub_o <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
stub_o forall a. [a] -> [a] -> [a]
++ [String]
foreign_os)

                    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 = do
       HscEnv
hsc_env <- CompPipeline HscEnv
getPipeSession
       Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
       String
output_fn <- Phase -> CompPipeline String
phaseOutputFilename Phase
Cmm
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> String
-> String
-> IO ()
doCpp Logger
logger
                      (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
                      (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                      (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
                      Bool
False{-not raw-}
                      String
input_fn String
output_fn
       forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
Cmm, String
output_fn)

runPhase (RealPhase Phase
Cmm) String
input_fn = do
       HscEnv
hsc_env <- CompPipeline HscEnv
getPipeSession
       let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
       let next_phase :: Phase
next_phase = HscSource -> Backend -> Phase
hscPostBackendPhase HscSource
HsSrcFile (DynFlags -> Backend
backend DynFlags
dflags)
       String
output_fn <- Phase -> CompPipeline String
phaseOutputFilename Phase
next_phase
       PipeState{HscEnv
hsc_env :: HscEnv
hsc_env :: PipeState -> HscEnv
hsc_env} <- CompPipeline PipeState
getPipeState
       Maybe String
mstub <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> String -> String -> IO (Maybe String)
hscCompileCmmFile HscEnv
hsc_env String
input_fn String
output_fn
       Maybe String
stub_o <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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] -> CompPipeline ()
setForeignOs (forall a. Maybe a -> [a]
maybeToList Maybe String
stub_o)
       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
   | 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
        HscEnv
hsc_env <- CompPipeline HscEnv
getPipeSession
        let dflags :: DynFlags
dflags    = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        let unit_env :: UnitEnv
unit_env  = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
        let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
        let tmpfs :: TmpFs
tmpfs     = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
        let platform :: Platform
platform  = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
        let 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 forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [UnitId]
getHCFilePackages String
input_fn else 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 :)
        [UnitInfo]
ps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
pkgs)
        let pkg_include_dirs :: [String]
pkg_include_dirs     = [UnitInfo] -> [String]
collectIncludeDirs [UnitInfo]
ps
        let include_paths_global :: [String]
include_paths_global = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ String
x [String]
xs -> (String
"-I" forall a. [a] -> [a] -> [a]
++ String
x) forall a. a -> [a] -> [a]
: [String]
xs) []
              (IncludeSpecs -> [String]
includePathsGlobal IncludeSpecs
cmdline_include_paths forall a. [a] -> [a] -> [a]
++ [String]
pkg_include_dirs)
        let include_paths_quote :: [String]
include_paths_quote = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ String
x [String]
xs -> (String
"-iquote" forall a. [a] -> [a] -> [a]
++ String
x) forall a. a -> [a] -> [a]
: [String]
xs) []
              (IncludeSpecs -> [String]
includePathsQuote IncludeSpecs
cmdline_include_paths forall a. [a] -> [a] -> [a]
++
               IncludeSpecs -> [String]
includePathsQuoteImplicit IncludeSpecs
cmdline_include_paths)
        let include_paths :: [String]
include_paths = [String]
include_paths_quote 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [String
"-Xpreprocessor", String
i]
              | Bool -> Bool
not Bool
hcc
              , String
i <- 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.
        let pkg_extra_cc_opts :: [String]
pkg_extra_cc_opts
                | Bool
hcc       = []
                | Bool
otherwise = [UnitInfo] -> [String]
collectExtraCcOpts [UnitInfo]
ps

        let framework_paths :: [String]
framework_paths
                | Platform -> Bool
platformUsesFrameworks Platform
platform
                = let pkgFrameworkPaths :: [String]
pkgFrameworkPaths     = [UnitInfo] -> [String]
collectFrameworksDirs [UnitInfo]
ps
                      cmdlineFrameworkPaths :: [String]
cmdlineFrameworkPaths = DynFlags -> [String]
frameworkPaths DynFlags
dflags
                  in forall a b. (a -> b) -> [a] -> [b]
map (String
"-F"forall a. [a] -> [a] -> [a]
++) ([String]
cmdlineFrameworkPaths forall a. [a] -> [a] -> [a]
++ [String]
pkgFrameworkPaths)
                | Bool
otherwise
                = []

        let cc_opt :: [String]
cc_opt | DynFlags -> Int
optLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
>= Int
2 = [ String
"-O2" ]
                   | DynFlags -> Int
optLevel DynFlags
dflags 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 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 []) 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitEnv -> IO String
getGhcVersionPathName DynFlags
dflags UnitEnv
unit_env

        Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Maybe ForeignSrcLang
-> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runCc (Phase -> Maybe ForeignSrcLang
phaseForeignLanguage Phase
cc_phase) Logger
logger TmpFs
tmpfs 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
                        ]
                       forall a. [a] -> [a] -> [a]
++ 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.
                       forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 Bool -> Bool -> Bool
&&
                              forall u. GenHomeUnit u -> UnitId -> Bool
isHomeUnitId HomeUnit
home_unit 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
                       forall a. [a] -> [a] -> [a]
++ (if Platform -> Arch
platformArch Platform
platform forall a. Eq a => a -> a -> Bool
== Arch
ArchSPARC
                           then [String
"-mcpu=v9"]
                           else [])

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

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

        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
  = do
        HscEnv
hsc_env <- CompPipeline HscEnv
getPipeSession
        let dflags :: DynFlags
dflags     = HscEnv -> DynFlags
hsc_dflags   HscEnv
hsc_env
        let logger :: Logger
logger     = HscEnv -> Logger
hsc_logger   HscEnv
hsc_env
        let unit_env :: UnitEnv
unit_env   = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
        let platform :: Platform
platform   = UnitEnv -> Platform
ue_platform UnitEnv
unit_env

        -- 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 :: Logger -> DynFlags -> [Option] -> IO ()
as_prog | DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
== Backend
LLVM
                    , Platform -> OS
platformOS Platform
platform forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
                    = Logger -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runClang
                    | Bool
otherwise
                    = Logger -> 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.
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
output_fn)

        CompilerInfo
ccInfo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO CompilerInfo
getCompilerInfo Logger
logger DynFlags
dflags
        let global_includes :: [Option]
global_includes = [ String -> Option
GHC.SysTools.Option (String
"-I" 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" forall a. [a] -> [a] -> [a]
++ String
p)
                             | String
p <- IncludeSpecs -> [String]
includePathsQuote IncludeSpecs
cmdline_include_paths forall a. [a] -> [a] -> [a]
++
                                IncludeSpecs -> [String]
includePathsQuoteImplicit IncludeSpecs
cmdline_include_paths]
        let runAssembler :: String -> String -> CompPipeline ()
runAssembler String
inputFilename String
outputFilename
              = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *) a.
MonadIO m =>
String -> (String -> m a) -> m a
withAtomicRename String
outputFilename forall a b. (a -> b) -> a -> b
$ \String
temp_outputFilename ->
                    Logger -> DynFlags -> [Option] -> IO ()
as_prog
                       Logger
logger DynFlags
dflags
                       ([Option]
local_includes forall a. [a] -> [a] -> [a]
++ [Option]
global_includes
                       -- See Note [-fPIC for assembler]
                       forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
pic_c_flags
                       -- See Note [Produce big objects on Windows]
                       forall a. [a] -> [a] -> [a]
++ [ String -> Option
GHC.SysTools.Option String
"-Wa,-mbig-obj"
                          | Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                          , Bool -> Bool
not 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.
                       forall a. [a] -> [a] -> [a]
++ (if Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) forall a. Eq a => a -> a -> Bool
== Arch
ArchSPARC
                           then [String -> Option
GHC.SysTools.Option String
"-mcpu=v9"]
                           else [])
                       forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CompilerInfo
ccInfo forall a. Eq a => a -> a -> Bool
==) [CompilerInfo
Clang, CompilerInfo
AppleClang, CompilerInfo
AppleClang51]
                            then [String -> Option
GHC.SysTools.Option String
"-Qunused-arguments"]
                            else [])
                       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
                          ])

        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
4 (String -> SDoc
text String
"Running the assembler")
        String -> String -> CompPipeline ()
runAssembler String
input_fn String
output_fn

        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 = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    let -- 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 = forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min Int
2 forall a b. (a -> b) -> a -> b
$ DynFlags -> Int
optLevel DynFlags
dflags  -- ensure we're in [0,2]
        llvmOpts :: String
llvmOpts = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
optIdx forall a b. (a -> b) -> a -> b
$ LlvmConfig -> [(Int, String)]
llvmPasses forall a b. (a -> b) -> a -> b
$ DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags of
                    Just String
passes -> String
passes
                    Maybe String
Nothing -> forall a. String -> a
panic (String
"runPhase LlvmOpt: llvm-passes file "
                                      forall a. [a] -> [a] -> [a]
++ String
"is missing passes for level "
                                      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
optIdx)
        defaultOptions :: [Option]
defaultOptions = forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
                         forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip (DynFlags -> [(String, String)]
llvmOptions DynFlags
dflags)

        -- 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [String]
opt_lo)
                  then forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
llvmOpts
                  else []

    String
output_fn <- Phase -> CompPipeline String
phaseOutputFilename Phase
LlvmLlc

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runLlvmOpt Logger
logger DynFlags
dflags
               (   [Option]
optFlag
                forall a. [a] -> [a] -> [a]
++ [Option]
defaultOptions 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]
                )

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


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

runPhase (RealPhase Phase
LlvmLlc) String
input_fn = do
    -- 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
    --
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    let
        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"

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

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

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

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runLlvmLlc Logger
logger DynFlags
dflags
                (  [Option]
optFlag
                forall a. [a] -> [a] -> [a]
++ [Option]
defaultOptions
                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
                   ]
                )

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



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

runPhase (RealPhase Phase
LlvmMangle) String
input_fn = do
      let next_phase :: Phase
next_phase = Bool -> Phase
As Bool
False
      String
output_fn <- Phase -> CompPipeline String
phaseOutputFilename Phase
next_phase
      DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> String -> String -> IO ()
llvmFixupAsm Logger
logger DynFlags
dflags String
input_fn String
output_fn
      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 = do
     PipeState{[String]
foreign_os :: [String]
foreign_os :: PipeState -> [String]
foreign_os,HscEnv
hsc_env :: HscEnv
hsc_env :: PipeState -> HscEnv
hsc_env} <- CompPipeline PipeState
getPipeState
     String
output_fn <- Phase -> CompPipeline String
phaseOutputFilename Phase
StopLn
     forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
output_fn)
     if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
foreign_os
       then forall a. String -> a
panic String
"runPhase(MergeForeign): no foreign objects"
       else do
         DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
         Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
         let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> [String] -> String -> IO ()
joinObjectFiles Logger
logger TmpFs
tmpfs DynFlags
dflags (String
input_fn forall a. a -> [a] -> [a]
: [String]
foreign_os) String
output_fn
         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 =
   forall a. String -> a
panic (String
"runPhase: don't know how to run phase " forall a. [a] -> [a] -> [a]
++ 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
foreign_os then forall (m :: * -> *) a. Monad m => a -> m a
return Phase
StopLn else 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 <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModLocation
l
        { ml_hs_file :: Maybe String
ml_hs_file = forall a. a -> Maybe a
Just 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
        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 =
  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 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 ->
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map String -> UnitId
stringToUnitId (String -> [String]
words String
rest))
      String
_other ->
          forall (m :: * -> *) a. Monad m => a -> m a
return []


linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkDynLibCheck :: Logger
-> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkDynLibCheck Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [String]
o_files [UnitId]
dep_units = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
haveRtsOptsFlags DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
    Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
NoReason Severity
SevInfo SrcSpan
noSrcSpan
      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.")
  Logger
-> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
linkDynLib Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [String]
o_files [UnitId]
dep_units


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

-- | Run CPP
--
-- UnitState is needed to compute MIN_VERSION macros
doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()
doCpp :: Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> String
-> String
-> IO ()
doCpp Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env 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
    let unit_state :: UnitState
unit_state = UnitEnv -> UnitState
ue_units UnitEnv
unit_env
    [String]
pkg_include_dirs <- forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr
                        ([UnitInfo] -> [String]
collectIncludeDirs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitEnv -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo UnitEnv
unit_env)
    let include_paths_global :: [String]
include_paths_global = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ String
x [String]
xs -> (String
"-I" forall a. [a] -> [a] -> [a]
++ String
x) forall a. a -> [a] -> [a]
: [String]
xs) []
          (IncludeSpecs -> [String]
includePathsGlobal IncludeSpecs
cmdline_include_paths forall a. [a] -> [a] -> [a]
++ [String]
pkg_include_dirs)
    let include_paths_quote :: [String]
include_paths_quote = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ String
x [String]
xs -> (String
"-iquote" forall a. [a] -> [a] -> [a]
++ String
x) forall a. a -> [a] -> [a]
: [String]
xs) []
          (IncludeSpecs -> [String]
includePathsQuote IncludeSpecs
cmdline_include_paths forall a. [a] -> [a] -> [a]
++
           IncludeSpecs -> [String]
includePathsQuoteImplicit IncludeSpecs
cmdline_include_paths)
    let include_paths :: [String]
include_paths = [String]
include_paths_quote 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       = Logger -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runCpp Logger
logger DynFlags
dflags [Option]
args
                      | Bool
otherwise = Maybe ForeignSrcLang
-> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runCc forall a. Maybe a
Nothing Logger
logger TmpFs
tmpfs DynFlags
dflags
                                        (String -> Option
GHC.SysTools.Option String
"-E" forall a. a -> [a] -> [a]
: [Option]
args)

    let platform :: Platform
platform   = DynFlags -> Platform
targetPlatform DynFlags
dflags
        targetArch :: String
targetArch = Arch -> String
stringEncodeArch forall a b. (a -> b) -> a -> b
$ Platform -> Arch
platformArch Platform
platform
        targetOS :: String
targetOS = OS -> String
stringEncodeOS forall a b. (a -> b) -> a -> b
$ Platform -> OS
platformOS Platform
platform
        isWindows :: Bool
isWindows = Platform -> OS
platformOS Platform
platform forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
    let target_defs :: [String]
target_defs =
          [ String
"-D" forall a. [a] -> [a] -> [a]
++ String
HOST_OS     forall a. [a] -> [a] -> [a]
++ String
"_BUILD_OS",
            String
"-D" forall a. [a] -> [a] -> [a]
++ HOST_ARCH   ++ "_BUILD_ARCH",
            String
"-D" forall a. [a] -> [a] -> [a]
++ String
targetOS    forall a. [a] -> [a] -> [a]
++ String
"_HOST_OS",
            String
"-D" forall a. [a] -> [a] -> [a]
++ String
targetArch  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 ] forall a. [a] -> [a] -> [a]
++
          [ String
"-D__IO_MANAGER_MIO__=1"               ]

    let sse_defs :: [String]
sse_defs =
          [ String
"-D__SSE__"      | Platform -> Bool
isSseEnabled      Platform
platform ] forall a. [a] -> [a] -> [a]
++
          [ String
"-D__SSE2__"     | Platform -> Bool
isSse2Enabled     Platform
platform ] 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 ] forall a. [a] -> [a] -> [a]
++
          [ String
"-D__AVX2__"     | DynFlags -> Bool
isAvx2Enabled     DynFlags
dflags ] forall a. [a] -> [a] -> [a]
++
          [ String
"-D__AVX512CD__" | DynFlags -> Bool
isAvx512cdEnabled DynFlags
dflags ] forall a. [a] -> [a] -> [a]
++
          [ String
"-D__AVX512ER__" | DynFlags -> Bool
isAvx512erEnabled DynFlags
dflags ] forall a. [a] -> [a] -> [a]
++
          [ String
"-D__AVX512F__"  | DynFlags -> Bool
isAvx512fEnabled  DynFlags
dflags ] forall a. [a] -> [a] -> [a]
++
          [ String
"-D__AVX512PF__" | DynFlags -> Bool
isAvx512pfEnabled DynFlags
dflags ]

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

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

    -- MIN_VERSION macros
    let uids :: [Unit]
uids = UnitState -> [Unit]
explicitUnits UnitState
unit_state
        pkgs :: [UnitInfo]
pkgs = forall a. [Maybe a] -> [a]
catMaybes (forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
unit_state) [Unit]
uids)
    [Option]
mb_macro_include <-
        if Bool -> Bool
not (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 <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs 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.
                    forall (m :: * -> *) a. Monad m => a -> m a
return [String -> String -> Option
GHC.SysTools.FileOption String
"-include" String
macro_stub]
            else forall (m :: * -> *) a. Monad m => a -> m a
return []

    [Option] -> IO ()
cpp_prog       (   forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
verbFlags
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
include_paths
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
hsSourceCppOpts
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
target_defs
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
backend_defs
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
th_defs
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
hscpp_opts
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
sse_defs
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
avx_defs
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
io_manager_defs
                    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.
                    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 :: Logger -> DynFlags -> IO [String]
getBackendDefs :: Logger -> DynFlags -> IO [String]
getBackendDefs Logger
logger DynFlags
dflags | DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
== Backend
LLVM = do
    Maybe LlvmVersion
llvmVer <- Logger -> DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion Logger
logger DynFlags
dflags
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case 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__=" forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
format (Int
m,Int
0) ]
               Just (Int
m:Int
n:[Int]
_) -> [ String
"-D__GLASGOW_HASKELL_LLVM__=" 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 forall a. Ord a => a -> a -> Bool
>= Int
100 = forall a. HasCallStack => String -> a
error String
"getBackendDefs: Unsupported minor version"
      | Bool
otherwise = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ (Int
100 forall a. Num a => a -> a -> a
* Int
major forall a. Num a => a -> a -> a
+ Int
minor :: Int) -- Contract is Int

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

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

generatePackageVersionMacros :: [UnitInfo] -> String
generatePackageVersionMacros :: [UnitInfo] -> String
generatePackageVersionMacros [UnitInfo]
pkgs = 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 = forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Version
unitPackageVersion UnitInfo
pkg
        pkgname :: String
pkgname = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar (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 =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [String
"#define ", String
prefix, String
"VERSION_",String
name,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]
_) = forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show (Version -> [Int]
versionBranch Version
version forall a. [a] -> [a] -> [a]
++ 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 :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [String] -> String -> IO ()
joinObjectFiles Logger
logger TmpFs
tmpfs 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 = Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runMergeObjects Logger
logger TmpFs
tmpfs DynFlags
dflags (
                        -- See Note [Produce big objects on Windows]
                        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 forall a. Eq a => a -> a -> Bool
== OS
osInfo
                          , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                          ]
                     forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Option
GHC.SysTools.Option [String]
ld_build_id
                     forall a. [a] -> [a] -> [a]
++ [ String -> Option
GHC.SysTools.Option String
"-o",
                          String -> String -> Option
GHC.SysTools.FileOption String
"" String
output_fn ]
                     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 <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
"ldscript"
          String
cwd <- IO String
getCurrentDirectory
          let o_files_abs :: [String]
o_files_abs = forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> String
"\"" forall a. [a] -> [a] -> [a]
++ (String
cwd String -> String -> String
</> String
x) forall a. [a] -> [a] -> [a]
++ String
"\"") [String]
o_files
          String -> String -> IO ()
writeFile String
script forall a b. (a -> b) -> a -> b
$ String
"INPUT(" forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
o_files_abs 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 <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
TFL_CurrentModule String
"filelist"
          String -> String -> IO ()
writeFile String
filelist 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
          [Option] -> IO ()
ld_r (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
&&
 Backend
NoBackend forall a. Eq a => a -> a -> Bool
== DynFlags -> Backend
backend 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 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
             forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t2 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 -> Backend -> Phase
hscPostBackendPhase :: HscSource -> Backend -> Phase
hscPostBackendPhase HscSource
HsBootFile Backend
_    =  Phase
StopLn
hscPostBackendPhase HscSource
HsigFile Backend
_      =  Phase
StopLn
hscPostBackendPhase HscSource
_ Backend
bcknd =
  case Backend
bcknd of
        Backend
ViaC        -> Phase
HCc
        Backend
NCG         -> Bool -> Phase
As Bool
False
        Backend
LLVM        -> Phase
LlvmOpt
        Backend
NoBackend   -> Phase
StopLn
        Backend
Interpreter -> Phase
StopLn

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

-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
getGhcVersionPathName :: DynFlags -> UnitEnv -> IO String
getGhcVersionPathName DynFlags
dflags UnitEnv
unit_env = do
  [String]
candidates <- case DynFlags -> Maybe String
ghcVersionFile DynFlags
dflags of
    Just String
path -> forall (m :: * -> *) a. Monad m => a -> m a
return [String
path]
    Maybe String
Nothing -> do
        [UnitInfo]
ps <- forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId
rtsUnitId])
        forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> String -> String
</> String
"ghcversion.h") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UnitInfo] -> [String]
collectIncludeDirs [UnitInfo]
ps)

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