{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Driver.Pipeline (
oneShot, compileFile,
linkBinary,
preprocess,
compileOne, compileOne',
link,
PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
runPhase, exeFileName,
maybeCreateManifest,
doCpp,
linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
) where
#include <ghcplatform.h>
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Tc.Types
import GHC.Driver.Main
import GHC.Driver.Env hiding ( Hsc )
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.SysTools.ExtraObj
import GHC.SysTools.FileCleanup
import GHC.SysTools.Ar
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.CmmToLlvm ( llvmFixupAsm, llvmVersionList )
import qualified GHC.LanguageExtensions as LangExt
import GHC.Settings
import GHC.Runtime.Linker.Types
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.Iface.UpdateIdInfos ( updateModDetailsIdInfos )
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.State
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModDetails
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 )
preprocess :: HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess :: HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
input_fn Maybe InputFileBuffer
mb_input_buf Maybe Phase
mb_phase =
(SourceError -> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
err -> Either ErrorMessages (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrorMessages -> Either ErrorMessages (DynFlags, FilePath)
forall a b. a -> Either a b
Left (SourceError -> ErrorMessages
srcErrorMessages SourceError
err))) (IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$
(GhcException -> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle GhcException -> IO (Either ErrorMessages (DynFlags, FilePath))
handler (IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (Either ErrorMessages (DynFlags, FilePath))
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$
((DynFlags, FilePath) -> Either ErrorMessages (DynFlags, FilePath))
-> IO (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags, FilePath) -> Either ErrorMessages (DynFlags, FilePath)
forall a b. b -> Either a b
Right (IO (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath)))
-> IO (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$ do
MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
(DynFlags
dflags, FilePath
fp, Maybe (ModIface, ModDetails)
mb_iface) <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline Phase
anyHsc HscEnv
hsc_env (FilePath
input_fn, Maybe InputFileBuffer
mb_input_buf, (Phase -> PhasePlus) -> Maybe Phase -> Maybe PhasePlus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Phase -> PhasePlus
RealPhase Maybe Phase
mb_phase)
Maybe FilePath
forall a. Maybe a
Nothing
(TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_GhcSession)
Maybe ModLocation
forall a. Maybe a
Nothing
[]
MASSERT(isNothing mb_iface)
(DynFlags, FilePath) -> IO (DynFlags, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags, FilePath
fp)
where
srcspan :: SrcSpan
srcspan = SrcLoc -> SrcSpan
srcLocSpan (SrcLoc -> SrcSpan) -> SrcLoc -> SrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
mkFastString FilePath
input_fn) Int
1 Int
1
handler :: GhcException -> IO (Either ErrorMessages (DynFlags, FilePath))
handler (ProgramError FilePath
msg) = Either ErrorMessages (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath)))
-> Either ErrorMessages (DynFlags, FilePath)
-> IO (Either ErrorMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages (DynFlags, FilePath)
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages (DynFlags, FilePath))
-> ErrorMessages -> Either ErrorMessages (DynFlags, FilePath)
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrorMessages
forall a. a -> Bag a
unitBag (ErrMsg -> ErrorMessages) -> ErrMsg -> ErrorMessages
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) SrcSpan
srcspan (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
msg
handler GhcException
ex = GhcException -> IO (Either ErrorMessages (DynFlags, FilePath))
forall a. GhcException -> IO a
throwGhcExceptionIO GhcException
ex
compileOne :: HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne :: HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne = Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
forall a. Maybe a
Nothing (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
batchMsg)
compileOne' :: Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' :: Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
m_tc_result Maybe Messager
mHscMessage
HscEnv
hsc_env0 ModSummary
summary Int
mod_index Int
nmods Maybe ModIface
mb_old_iface Maybe Linkable
mb_old_linkable
SourceModified
source_modified0
= do
DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags1 Int
2 (FilePath -> SDoc
text FilePath
"compile: input file" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
input_fnpp)
(HscStatus
status, DynFlags
plugin_dflags) <- Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, DynFlags)
hscIncrementalCompile
Bool
always_do_basic_recompilation_check
Maybe TcGblEnv
m_tc_result Maybe Messager
mHscMessage
HscEnv
hsc_env ModSummary
summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int
mod_index, Int
nmods)
let flags :: DynFlags
flags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env0
in do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepHiFiles DynFlags
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean DynFlags
flags TempFileLifetime
TFL_CurrentModule ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$
[ModLocation -> FilePath
ml_hi_file (ModLocation -> FilePath) -> ModLocation -> FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
summary]
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepOFiles DynFlags
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean DynFlags
flags TempFileLifetime
TFL_GhcSession ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$
[ModLocation -> FilePath
ml_obj_file (ModLocation -> FilePath) -> ModLocation -> FilePath
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
summary]
let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env{ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
plugin_dflags }
case (HscStatus
status, Backend
bcknd) of
(HscUpToDate ModIface
iface ModDetails
hmi_details, Backend
_) ->
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details Maybe Linkable
mb_old_linkable
(HscNotGeneratingCode ModIface
iface ModDetails
hmi_details, Backend
NoBackend) ->
let mb_linkable :: Maybe Linkable
mb_linkable = if HscSource -> Bool
isHsBootOrSig HscSource
src_flavour
then Maybe Linkable
forall a. Maybe a
Nothing
else Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just (UTCTime -> Module -> [Unlinked] -> Linkable
LM (ModSummary -> UTCTime
ms_hs_date ModSummary
summary) Module
this_mod [])
in HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details Maybe Linkable
mb_linkable
(HscNotGeneratingCode ModIface
_ ModDetails
_, Backend
_) -> FilePath -> IO HomeModInfo
forall a. FilePath -> a
panic FilePath
"compileOne HscNotGeneratingCode"
(HscStatus
_, Backend
NoBackend) -> FilePath -> IO HomeModInfo
forall a. FilePath -> a
panic FilePath
"compileOne NoBackend"
(HscUpdateBoot ModIface
iface ModDetails
hmi_details, Backend
Interpreter) ->
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details Maybe Linkable
forall a. Maybe a
Nothing
(HscUpdateBoot ModIface
iface ModDetails
hmi_details, Backend
_) -> do
DynFlags -> FilePath -> IO ()
touchObjectFile DynFlags
dflags FilePath
object_filename
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details Maybe Linkable
forall a. Maybe a
Nothing
(HscUpdateSig ModIface
iface ModDetails
hmi_details, Backend
Interpreter) -> do
let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM (ModSummary -> UTCTime
ms_hs_date ModSummary
summary) Module
this_mod []
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable)
(HscUpdateSig ModIface
iface ModDetails
hmi_details, Backend
_) -> do
FilePath
output_fn <- Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename Phase
next_phase
(TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule) FilePath
basename DynFlags
dflags
Phase
next_phase (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
(DynFlags, FilePath, Maybe (ModIface, ModDetails))
_ <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline Phase
StopLn HscEnv
hsc_env'
(FilePath
output_fn,
Maybe InputFileBuffer
forall a. Maybe a
Nothing,
PhasePlus -> Maybe PhasePlus
forall a. a -> Maybe a
Just (HscSource -> ModuleName -> HscStatus -> PhasePlus
HscOut HscSource
src_flavour
ModuleName
mod_name (ModIface -> ModDetails -> HscStatus
HscUpdateSig ModIface
iface ModDetails
hmi_details)))
(FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
basename)
PipelineOutput
Persistent
(ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
[]
UTCTime
o_time <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
object_filename
let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
o_time Module
this_mod [FilePath -> Unlinked
DotO FilePath
object_filename]
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
hmi_details (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable)
(HscRecomp { hscs_guts :: HscStatus -> CgGuts
hscs_guts = CgGuts
cgguts,
hscs_mod_location :: HscStatus -> ModLocation
hscs_mod_location = ModLocation
mod_location,
hscs_mod_details :: HscStatus -> ModDetails
hscs_mod_details = ModDetails
hmi_details,
hscs_partial_iface :: HscStatus -> PartialModIface
hscs_partial_iface = PartialModIface
partial_iface,
hscs_old_iface_hash :: HscStatus -> Maybe Fingerprint
hscs_old_iface_hash = Maybe Fingerprint
mb_old_iface_hash,
hscs_iface_dflags :: HscStatus -> DynFlags
hscs_iface_dflags = DynFlags
iface_dflags }, Backend
Interpreter) -> do
ModIface
final_iface <- HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
mkFullIface HscEnv
hsc_env'{hsc_dflags :: DynFlags
hsc_dflags=DynFlags
iface_dflags} PartialModIface
partial_iface Maybe CgInfos
forall a. Maybe a
Nothing
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
hscMaybeWriteIface DynFlags
dflags ModIface
final_iface Maybe Fingerprint
mb_old_iface_hash (ModSummary -> ModLocation
ms_location ModSummary
summary)
(Maybe FilePath
hasStub, CompiledByteCode
comp_bc, [SptEntry]
spt_entries) <- HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive HscEnv
hsc_env' CgGuts
cgguts ModLocation
mod_location
[Unlinked]
stub_o <- case Maybe FilePath
hasStub of
Maybe FilePath
Nothing -> [Unlinked] -> IO [Unlinked]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just FilePath
stub_c -> do
FilePath
stub_o <- HscEnv -> FilePath -> IO FilePath
compileStub HscEnv
hsc_env' FilePath
stub_c
[Unlinked] -> IO [Unlinked]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> Unlinked
DotO FilePath
stub_o]
let hs_unlinked :: [Unlinked]
hs_unlinked = [CompiledByteCode -> [SptEntry] -> Unlinked
BCOs CompiledByteCode
comp_bc [SptEntry]
spt_entries]
unlinked_time :: UTCTime
unlinked_time = ModSummary -> UTCTime
ms_hs_date ModSummary
summary
let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
unlinked_time (ModSummary -> Module
ms_mod ModSummary
summary)
([Unlinked]
hs_unlinked [Unlinked] -> [Unlinked] -> [Unlinked]
forall a. [a] -> [a] -> [a]
++ [Unlinked]
stub_o)
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
final_iface ModDetails
hmi_details (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable)
(HscRecomp{}, Backend
_) -> do
FilePath
output_fn <- Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename Phase
next_phase
(TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_CurrentModule)
FilePath
basename DynFlags
dflags Phase
next_phase (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
(DynFlags
_, FilePath
_, Just (ModIface
iface, ModDetails
details)) <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline Phase
StopLn HscEnv
hsc_env'
(FilePath
output_fn,
Maybe InputFileBuffer
forall a. Maybe a
Nothing,
PhasePlus -> Maybe PhasePlus
forall a. a -> Maybe a
Just (HscSource -> ModuleName -> HscStatus -> PhasePlus
HscOut HscSource
src_flavour ModuleName
mod_name HscStatus
status))
(FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
basename)
PipelineOutput
Persistent
(ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
[]
UTCTime
o_time <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
object_filename
let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
o_time Module
this_mod [FilePath -> Unlinked
DotO FilePath
object_filename]
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> IO HomeModInfo) -> HomeModInfo -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$! ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable)
where dflags0 :: DynFlags
dflags0 = ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary
this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
summary
location :: ModLocation
location = ModSummary -> ModLocation
ms_location ModSummary
summary
input_fn :: FilePath
input_fn = FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"compile:hs" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location)
input_fnpp :: FilePath
input_fnpp = ModSummary -> FilePath
ms_hspp_file ModSummary
summary
mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env0
needsLinker :: Bool
needsLinker = ModuleGraph -> Bool
needsTemplateHaskellOrQQ ModuleGraph
mod_graph
isDynWay :: Bool
isDynWay = (Way -> Bool) -> Set Way -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
== Way
WayDyn) (DynFlags -> Set Way
ways DynFlags
dflags0)
isProfWay :: Bool
isProfWay = (Way -> Bool) -> Set Way -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
== Way
WayProf) (DynFlags -> Set Way
ways DynFlags
dflags0)
internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags0)
src_flavour :: HscSource
src_flavour = ModSummary -> HscSource
ms_hsc_src ModSummary
summary
mod_name :: ModuleName
mod_name = ModSummary -> ModuleName
ms_mod_name ModSummary
summary
next_phase :: Phase
next_phase = HscSource -> Backend -> Phase
hscPostBackendPhase HscSource
src_flavour Backend
bcknd
object_filename :: FilePath
object_filename = ModLocation -> FilePath
ml_obj_file ModLocation
location
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
dflags2 :: DynFlags
dflags2 = if Bool -> Bool
not Bool
internalInterpreter Bool -> Bool -> Bool
&& Bool
needsLinker
then DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags1 GeneralFlag
Opt_ExternalInterpreter
else DynFlags
dflags1
basename :: FilePath
basename = FilePath -> FilePath
dropExtension FilePath
input_fn
current_dir :: FilePath
current_dir = FilePath -> FilePath
takeDirectory FilePath
basename
old_paths :: IncludeSpecs
old_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags2
!prevailing_dflags :: DynFlags
prevailing_dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env0
(Backend
bcknd, DynFlags
dflags3)
| 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
= (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 -> [FilePath] -> IncludeSpecs
addQuoteInclude IncludeSpecs
old_paths [FilePath
current_dir]
, log_action :: LogAction
log_action = DynFlags -> LogAction
log_action DynFlags
prevailing_dflags }
hsc_env :: HscEnv
hsc_env = HscEnv
hsc_env0 {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags}
force_recomp :: Bool
force_recomp = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp DynFlags
dflags
source_modified :: SourceModified
source_modified
| Bool
force_recomp = SourceModified
SourceModified
| Bool
otherwise = SourceModified
source_modified0
always_do_basic_recompilation_check :: Bool
always_do_basic_recompilation_check = case Backend
bcknd of
Backend
Interpreter -> Bool
True
Backend
_ -> Bool
False
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign HscEnv
_ ForeignSrcLang
RawObject FilePath
object_file = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
object_file
compileForeign HscEnv
hsc_env ForeignSrcLang
lang FilePath
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
#if __GLASGOW_HASKELL__ < 811
ForeignSrcLang
RawObject -> FilePath -> Phase
forall a. FilePath -> a
panic FilePath
"compileForeign: should be unreachable"
#endif
(DynFlags
_, FilePath
stub_o, Maybe (ModIface, ModDetails)
_) <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline Phase
StopLn HscEnv
hsc_env
(FilePath
stub_c, Maybe InputFileBuffer
forall a. Maybe a
Nothing, PhasePlus -> Maybe PhasePlus
forall a. a -> Maybe a
Just (Phase -> PhasePlus
RealPhase Phase
phase))
Maybe FilePath
forall a. Maybe a
Nothing (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_GhcSession)
Maybe ModLocation
forall a. Maybe a
Nothing
[]
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
stub_o
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub HscEnv
hsc_env FilePath
stub_c = HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign HscEnv
hsc_env ForeignSrcLang
LangC FilePath
stub_c
compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub :: DynFlags
-> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub DynFlags
dflags HscEnv
hsc_env FilePath
basename ModLocation
location ModuleName
mod_name = do
FilePath
empty_stub <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"c"
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
src :: SDoc
src = FilePath -> SDoc
text FilePath
"int" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name) SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"= 0;"
FilePath -> FilePath -> IO ()
writeFile FilePath
empty_stub (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (LabelStyle -> SDoc -> SDoc
pprCode LabelStyle
CStyle SDoc
src))
(DynFlags, FilePath, Maybe (ModIface, ModDetails))
_ <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline Phase
StopLn HscEnv
hsc_env
(FilePath
empty_stub, Maybe InputFileBuffer
forall a. Maybe a
Nothing, Maybe PhasePlus
forall a. Maybe a
Nothing)
(FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
basename)
PipelineOutput
Persistent
(ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location)
[]
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
link :: GhcLink
-> DynFlags
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link :: GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link GhcLink
ghcLink DynFlags
dflags
= (Hooks
-> Maybe
(GhcLink
-> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag))
-> (GhcLink
-> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
-> DynFlags
-> GhcLink
-> DynFlags
-> Bool
-> HomePackageTable
-> IO SuccessFlag
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks
-> Maybe
(GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
linkHook GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
l DynFlags
dflags GhcLink
ghcLink DynFlags
dflags
where
l :: GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
l GhcLink
LinkInMemory DynFlags
_ Bool
_ HomePackageTable
_
= if PlatformMisc -> Bool
platformMisc_ghcWithInterpreter (PlatformMisc -> Bool) -> PlatformMisc -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
then
SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
else GhcLink -> IO SuccessFlag
forall a. GhcLink -> a
panicBadLink GhcLink
LinkInMemory
l GhcLink
NoLink DynFlags
_ Bool
_ HomePackageTable
_
= SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
l GhcLink
LinkBinary DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
= DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link' DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
l GhcLink
LinkStaticLib DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
= DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link' DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
l GhcLink
LinkDynLib DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
= DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link' DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
panicBadLink :: GhcLink -> a
panicBadLink :: GhcLink -> a
panicBadLink GhcLink
other = FilePath -> a
forall a. FilePath -> a
panic (FilePath
"link: GHC not built to link this way: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
GhcLink -> FilePath
forall a. Show a => a -> FilePath
show GhcLink
other)
link' :: DynFlags
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link' :: DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link' DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
| Bool
batch_attempt_linking
= do
let
staticLink :: Bool
staticLink = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
GhcLink
LinkStaticLib -> Bool
True
GhcLink
_ -> Bool
False
home_mod_infos :: [HomeModInfo]
home_mod_infos = HomePackageTable -> [HomeModInfo]
eltsHpt HomePackageTable
hpt
pkg_deps :: [UnitId]
pkg_deps = (HomeModInfo -> [UnitId]) -> [HomeModInfo] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((UnitId, Bool) -> UnitId) -> [(UnitId, Bool)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, Bool) -> UnitId
forall a b. (a, b) -> a
fst ([(UnitId, Bool)] -> [UnitId])
-> (HomeModInfo -> [(UnitId, Bool)]) -> HomeModInfo -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [(UnitId, Bool)]
dep_pkgs (Dependencies -> [(UnitId, Bool)])
-> (HomeModInfo -> Dependencies) -> HomeModInfo -> [(UnitId, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps (ModIface -> Dependencies)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Dependencies
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
home_mod_infos
linkables :: [Linkable]
linkables = (HomeModInfo -> Linkable) -> [HomeModInfo] -> [Linkable]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe Linkable -> Linkable
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"link"(Maybe Linkable -> Linkable)
-> (HomeModInfo -> Maybe Linkable) -> HomeModInfo -> Linkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> Maybe Linkable
hm_linkable) [HomeModInfo]
home_mod_infos
DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
3 (FilePath -> SDoc
text FilePath
"link: linkables are ..." SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((Linkable -> SDoc) -> [Linkable] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Linkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Linkable]
linkables))
if GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
then do DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
3 (FilePath -> SDoc
text FilePath
"link(batch): linking omitted (-c flag given).")
SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
else do
let getOfiles :: Linkable -> [FilePath]
getOfiles (LM UTCTime
_ Module
_ [Unlinked]
us) = (Unlinked -> FilePath) -> [Unlinked] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Unlinked -> FilePath
nameOfObject ((Unlinked -> Bool) -> [Unlinked] -> [Unlinked]
forall a. (a -> Bool) -> [a] -> [a]
filter Unlinked -> Bool
isObject [Unlinked]
us)
obj_files :: [FilePath]
obj_files = (Linkable -> [FilePath]) -> [Linkable] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Linkable -> [FilePath]
getOfiles [Linkable]
linkables
exe_file :: FilePath
exe_file = Bool -> DynFlags -> FilePath
exeFileName Bool
staticLink DynFlags
dflags
Bool
linking_needed <- DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded DynFlags
dflags Bool
staticLink [Linkable]
linkables [UnitId]
pkg_deps
if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp DynFlags
dflags) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
linking_needed
then do DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
exe_file SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"is up to date, linking not required.")
SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
else do
DynFlags -> SDoc -> IO ()
compilationProgressMsg DynFlags
dflags (FilePath -> SDoc
text FilePath
"Linking " SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
exe_file SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
" ...")
let link :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
link = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
GhcLink
LinkBinary -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary
GhcLink
LinkStaticLib -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkStaticLib
GhcLink
LinkDynLib -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkDynLibCheck
GhcLink
other -> GhcLink -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
forall a. GhcLink -> a
panicBadLink GhcLink
other
DynFlags -> [FilePath] -> [UnitId] -> IO ()
link DynFlags
dflags [FilePath]
obj_files [UnitId]
pkg_deps
DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
3 (FilePath -> SDoc
text FilePath
"link: done")
SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
| Bool
otherwise
= do DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
3 (FilePath -> SDoc
text FilePath
"link(batch): upsweep (partially) failed OR" SDoc -> SDoc -> SDoc
$$
FilePath -> SDoc
text FilePath
" Main.main not exported; not linking.")
SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool
linkingNeeded DynFlags
dflags Bool
staticLink [Linkable]
linkables [UnitId]
pkg_deps = do
let exe_file :: FilePath
exe_file = Bool -> DynFlags -> FilePath
exeFileName Bool
staticLink DynFlags
dflags
Either IOException UTCTime
e_exe_time <- IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
tryIO (IO UTCTime -> IO (Either IOException UTCTime))
-> IO UTCTime -> IO (Either IOException UTCTime)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime FilePath
exe_file
case Either IOException UTCTime
e_exe_time of
Left IOException
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Right UTCTime
t -> do
let extra_ld_inputs :: [FilePath]
extra_ld_inputs = [ FilePath
f | FileOption FilePath
_ FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
[Either IOException UTCTime]
e_extra_times <- (FilePath -> IO (Either IOException UTCTime))
-> [FilePath] -> IO [Either IOException UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
tryIO (IO UTCTime -> IO (Either IOException UTCTime))
-> (FilePath -> IO UTCTime)
-> FilePath
-> IO (Either IOException UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO UTCTime
getModificationUTCTime) [FilePath]
extra_ld_inputs
let ([IOException]
errs,[UTCTime]
extra_times) = [Either IOException UTCTime] -> ([IOException], [UTCTime])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either IOException UTCTime]
e_extra_times
let obj_times :: [UTCTime]
obj_times = (Linkable -> UTCTime) -> [Linkable] -> [UTCTime]
forall a b. (a -> b) -> [a] -> [b]
map Linkable -> UTCTime
linkableTime [Linkable]
linkables [UTCTime] -> [UTCTime] -> [UTCTime]
forall a. [a] -> [a] -> [a]
++ [UTCTime]
extra_times
if Bool -> Bool
not ([IOException] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IOException]
errs) Bool -> Bool -> Bool
|| (UTCTime -> Bool) -> [UTCTime] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) [UTCTime]
obj_times
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
let unit_state :: UnitState
unit_state = DynFlags -> UnitState
unitState DynFlags
dflags
let pkg_hslibs :: [([FilePath], FilePath)]
pkg_hslibs = [ (Set Way -> [UnitInfo] -> [FilePath]
collectLibraryPaths (DynFlags -> Set Way
ways DynFlags
dflags) [UnitInfo
c], FilePath
lib)
| Just UnitInfo
c <- (UnitId -> Maybe UnitInfo) -> [UnitId] -> [Maybe UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
unit_state) [UnitId]
pkg_deps,
FilePath
lib <- DynFlags -> UnitInfo -> [FilePath]
packageHsLibs DynFlags
dflags UnitInfo
c ]
[Maybe FilePath]
pkg_libfiles <- (([FilePath], FilePath) -> IO (Maybe FilePath))
-> [([FilePath], FilePath)] -> IO [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([FilePath] -> FilePath -> IO (Maybe FilePath))
-> ([FilePath], FilePath) -> IO (Maybe FilePath)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DynFlags -> [FilePath] -> FilePath -> IO (Maybe FilePath)
findHSLib DynFlags
dflags)) [([FilePath], FilePath)]
pkg_hslibs
if (Maybe FilePath -> Bool) -> [Maybe FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe FilePath]
pkg_libfiles then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else do
[Either IOException UTCTime]
e_lib_times <- (FilePath -> IO (Either IOException UTCTime))
-> [FilePath] -> IO [Either IOException UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
tryIO (IO UTCTime -> IO (Either IOException UTCTime))
-> (FilePath -> IO UTCTime)
-> FilePath
-> IO (Either IOException UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO UTCTime
getModificationUTCTime)
([Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes [Maybe FilePath]
pkg_libfiles)
let ([IOException]
lib_errs,[UTCTime]
lib_times) = [Either IOException UTCTime] -> ([IOException], [UTCTime])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either IOException UTCTime]
e_lib_times
if Bool -> Bool
not ([IOException] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IOException]
lib_errs) Bool -> Bool -> Bool
|| (UTCTime -> Bool) -> [UTCTime] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) [UTCTime]
lib_times
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else DynFlags -> [UnitId] -> FilePath -> IO Bool
checkLinkInfo DynFlags
dflags [UnitId]
pkg_deps FilePath
exe_file
findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
findHSLib :: DynFlags -> [FilePath] -> FilePath -> IO (Maybe FilePath)
findHSLib DynFlags
dflags [FilePath]
dirs FilePath
lib = do
let batch_lib_file :: FilePath
batch_lib_file = if Way
WayDyn Way -> Set Way -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` DynFlags -> Set Way
ways DynFlags
dflags
then FilePath
"lib" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
lib FilePath -> FilePath -> FilePath
<.> FilePath
"a"
else Platform -> FilePath -> FilePath
platformSOName (DynFlags -> Platform
targetPlatform DynFlags
dflags) FilePath
lib
[FilePath]
found <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
batch_lib_file) [FilePath]
dirs)
case [FilePath]
found of
[] -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
(FilePath
x:[FilePath]
_) -> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
x)
oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
oneShot :: HscEnv -> Phase -> [(FilePath, Maybe Phase)] -> IO ()
oneShot HscEnv
hsc_env Phase
stop_phase [(FilePath, Maybe Phase)]
srcs = do
[FilePath]
o_files <- ((FilePath, Maybe Phase) -> IO FilePath)
-> [(FilePath, Maybe Phase)] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile HscEnv
hsc_env Phase
stop_phase) [(FilePath, Maybe Phase)]
srcs
DynFlags -> Phase -> [FilePath] -> IO ()
doLink (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Phase
stop_phase [FilePath]
o_files
compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
compileFile HscEnv
hsc_env Phase
stop_phase (FilePath
src, Maybe Phase
mb_phase) = do
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
src
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
exists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
CmdLineError (FilePath
"does not exist: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
src))
let
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
mb_o_file :: Maybe FilePath
mb_o_file = DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
ghc_link :: GhcLink
ghc_link = DynFlags -> GhcLink
ghcLink DynFlags
dflags
output :: PipelineOutput
output
| 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
| Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
mb_o_file = PipelineOutput
SpecificFile
| Bool
otherwise = PipelineOutput
Persistent
( DynFlags
_, FilePath
out_file, Maybe (ModIface, ModDetails)
_) <- Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline Phase
stop_phase HscEnv
hsc_env
(FilePath
src, Maybe InputFileBuffer
forall a. Maybe a
Nothing, (Phase -> PhasePlus) -> Maybe Phase -> Maybe PhasePlus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Phase -> PhasePlus
RealPhase Maybe Phase
mb_phase)
Maybe FilePath
forall a. Maybe a
Nothing
PipelineOutput
output
Maybe ModLocation
forall a. Maybe a
Nothing []
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
out_file
doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
doLink DynFlags
dflags Phase
stop_phase [FilePath]
o_files
| Bool -> Bool
not (Phase -> Bool
isStopLn Phase
stop_phase)
= () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
GhcLink
NoLink -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
GhcLink
LinkBinary -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary DynFlags
dflags [FilePath]
o_files []
GhcLink
LinkStaticLib -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkStaticLib DynFlags
dflags [FilePath]
o_files []
GhcLink
LinkDynLib -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkDynLibCheck DynFlags
dflags [FilePath]
o_files []
GhcLink
other -> GhcLink -> IO ()
forall a. GhcLink -> a
panicBadLink GhcLink
other
runPipeline
:: Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline :: Phase
-> HscEnv
-> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-> Maybe FilePath
-> PipelineOutput
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline Phase
stop_phase HscEnv
hsc_env0 (FilePath
input_fn, Maybe InputFileBuffer
mb_input_buf, Maybe PhasePlus
mb_phase)
Maybe FilePath
mb_basename PipelineOutput
output Maybe ModLocation
maybe_loc [FilePath]
foreign_os
= do let
dflags0 :: DynFlags
dflags0 = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env0
dflags :: DynFlags
dflags = DynFlags
dflags0 { dumpPrefix :: Maybe FilePath
dumpPrefix = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
basename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".") }
hsc_env :: HscEnv
hsc_env = HscEnv
hsc_env0 {hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags}
(FilePath
input_basename, FilePath
suffix) = FilePath -> (FilePath, FilePath)
splitExtension FilePath
input_fn
suffix' :: FilePath
suffix' = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
suffix
basename :: FilePath
basename | Just FilePath
b <- Maybe FilePath
mb_basename = FilePath
b
| Bool
otherwise = FilePath
input_basename
start_phase :: PhasePlus
start_phase = PhasePlus -> Maybe PhasePlus -> PhasePlus
forall a. a -> Maybe a -> a
fromMaybe (Phase -> PhasePlus
RealPhase (FilePath -> Phase
startPhase FilePath
suffix')) Maybe PhasePlus
mb_phase
isHaskell :: PhasePlus -> Bool
isHaskell (RealPhase (Unlit 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
-> FilePath -> FilePath -> FilePath -> PipelineOutput -> PipeEnv
PipeEnv{ Phase
stop_phase :: Phase
stop_phase :: Phase
stop_phase,
src_filename :: FilePath
src_filename = FilePath
input_fn,
src_basename :: FilePath
src_basename = FilePath
basename,
src_suffix :: FilePath
src_suffix = FilePath
suffix',
output_spec :: PipelineOutput
output_spec = PipelineOutput
output }
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> Bool
isBackpackishSuffix FilePath
suffix') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
UsageError
(FilePath
"use --backpack to process " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input_fn))
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' ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Phase
start_phase' Phase -> Phase -> Bool
`happensBefore'` Phase
stop_phase Bool -> Bool -> Bool
||
Phase
start_phase' Phase -> Phase -> Bool
`eqPhase` Phase
stop_phase)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
UsageError
(FilePath
"cannot compile this file to desired target: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input_fn))
HscOut {} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
FilePath
input_fn' <- case (PhasePlus
start_phase, Maybe InputFileBuffer
mb_input_buf) of
(RealPhase Phase
real_start_phase, Just InputFileBuffer
input_buf) -> do
let suffix :: FilePath
suffix = Phase -> FilePath
phaseInputExt Phase
real_start_phase
FilePath
fn <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
suffix
Handle
hdl <- FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
fn IOMode
WriteMode
Handle -> FilePath -> IO ()
hPutStrLn Handle
hdl (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"{-# LINE 1 \""FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input_fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"#-}"
Handle -> InputFileBuffer -> IO ()
hPutStringBuffer Handle
hdl InputFileBuffer
input_buf
Handle -> IO ()
hClose Handle
hdl
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fn
(PhasePlus
_, Maybe InputFileBuffer
_) -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
input_fn
DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
4 (FilePath -> SDoc
text FilePath
"Running the pipeline")
(DynFlags, FilePath, Maybe (ModIface, ModDetails))
r <- PhasePlus
-> HscEnv
-> PipeEnv
-> FilePath
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline' PhasePlus
start_phase HscEnv
hsc_env PipeEnv
env FilePath
input_fn'
Maybe ModLocation
maybe_loc [FilePath]
foreign_os
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHaskellishFile (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO () -> IO ()
forall (m :: * -> *). MonadIO m => DynFlags -> m () -> m ()
whenCannotGenerateDynamicToo DynFlags
dflags (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
4
(FilePath -> SDoc
text FilePath
"Running the pipeline again for -dynamic-too")
let dflags' :: DynFlags
dflags' = DynFlags -> DynFlags
dynamicTooMkDynamicDynFlags DynFlags
dflags
HscEnv
hsc_env' <- DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags'
(DynFlags, FilePath, Maybe (ModIface, ModDetails))
_ <- PhasePlus
-> HscEnv
-> PipeEnv
-> FilePath
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline' PhasePlus
start_phase HscEnv
hsc_env' PipeEnv
env FilePath
input_fn'
Maybe ModLocation
maybe_loc [FilePath]
foreign_os
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(DynFlags, FilePath, Maybe (ModIface, ModDetails))
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags, FilePath, Maybe (ModIface, ModDetails))
r
runPipeline'
:: PhasePlus
-> HscEnv
-> PipeEnv
-> FilePath
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline' :: PhasePlus
-> HscEnv
-> PipeEnv
-> FilePath
-> Maybe ModLocation
-> [FilePath]
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
runPipeline' PhasePlus
start_phase HscEnv
hsc_env PipeEnv
env FilePath
input_fn
Maybe ModLocation
maybe_loc [FilePath]
foreign_os
= do
let state :: PipeState
state = PipeState :: HscEnv
-> Maybe ModLocation
-> [FilePath]
-> Maybe (ModIface, ModDetails)
-> PipeState
PipeState{ HscEnv
hsc_env :: HscEnv
hsc_env :: HscEnv
hsc_env, Maybe ModLocation
maybe_loc :: Maybe ModLocation
maybe_loc :: Maybe ModLocation
maybe_loc, foreign_os :: [FilePath]
foreign_os = [FilePath]
foreign_os, iface :: Maybe (ModIface, ModDetails)
iface = Maybe (ModIface, ModDetails)
forall a. Maybe a
Nothing }
(PipeState
pipe_state, FilePath
fp) <- CompPipeline FilePath
-> PipeEnv -> PipeState -> IO (PipeState, FilePath)
forall a.
CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
evalP (PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop PhasePlus
start_phase FilePath
input_fn) PipeEnv
env PipeState
state
(DynFlags, FilePath, Maybe (ModIface, ModDetails))
-> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState -> DynFlags
pipeStateDynFlags PipeState
pipe_state, FilePath
fp, PipeState -> Maybe (ModIface, ModDetails)
pipeStateModIface PipeState
pipe_state)
pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop PhasePlus
phase FilePath
input_fn = do
PipeEnv
env <- CompPipeline PipeEnv
getPipeEnv
DynFlags
dflags <- CompPipeline DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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
->
case PipeEnv -> PipelineOutput
output_spec PipeEnv
env of
Temporary TempFileLifetime
_ ->
FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
input_fn
PipelineOutput
output ->
do PipeState
pst <- CompPipeline PipeState
getPipeState
FilePath
final_fn <- IO FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> CompPipeline FilePath)
-> IO FilePath -> CompPipeline FilePath
forall a b. (a -> b) -> a -> b
$ Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename
Phase
stopPhase PipelineOutput
output (PipeEnv -> FilePath
src_basename PipeEnv
env)
DynFlags
dflags Phase
stopPhase (PipeState -> Maybe ModLocation
maybe_loc PipeState
pst)
Bool -> CompPipeline () -> CompPipeline ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
final_fn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
input_fn) (CompPipeline () -> CompPipeline ())
-> CompPipeline () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ do
let msg :: FilePath
msg = (FilePath
"Copying `" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
input_fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"' to `" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
final_fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'")
line_prag :: Maybe FilePath
line_prag = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
"{-# LINE 1 \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PipeEnv -> FilePath
src_filename PipeEnv
env FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\" #-}\n")
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> FilePath -> Maybe FilePath -> FilePath -> FilePath -> IO ()
copyWithHeader DynFlags
dflags FilePath
msg Maybe FilePath
line_prag FilePath
input_fn FilePath
final_fn
FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
final_fn
| Bool -> Bool
not (Phase
realPhase Phase -> Phase -> Bool
`happensBefore'` Phase
stopPhase)
-> FilePath -> CompPipeline FilePath
forall a. FilePath -> a
panic (FilePath
"pipeLoop: at phase " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Phase -> FilePath
forall a. Show a => a -> FilePath
show Phase
realPhase FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" but I wanted to stop at phase " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Phase -> FilePath
forall a. Show a => a -> FilePath
show Phase
stopPhase)
PhasePlus
_
-> do IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
4
(FilePath -> SDoc
text FilePath
"Running phase" SDoc -> SDoc -> SDoc
<+> PhasePlus -> SDoc
forall a. Outputable a => a -> SDoc
ppr PhasePlus
phase)
(PhasePlus
next_phase, FilePath
output_fn) <- PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
runHookedPhase PhasePlus
phase FilePath
input_fn DynFlags
dflags
case PhasePlus
phase of
HscOut {} -> do
let noDynToo :: CompPipeline FilePath
noDynToo = PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop PhasePlus
next_phase FilePath
output_fn
let dynToo :: CompPipeline FilePath
dynToo = do
DynFlags -> CompPipeline ()
setDynFlags (DynFlags -> CompPipeline ()) -> DynFlags -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
dflags GeneralFlag
Opt_BuildDynamicToo
FilePath
r <- PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop PhasePlus
next_phase FilePath
output_fn
DynFlags -> CompPipeline ()
setDynFlags (DynFlags -> CompPipeline ()) -> DynFlags -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
dynamicTooMkDynamicDynFlags DynFlags
dflags
FilePath
_ <- PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop PhasePlus
phase FilePath
input_fn
FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
r
DynFlags
-> CompPipeline FilePath
-> CompPipeline FilePath
-> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => DynFlags -> m a -> m a -> m a
ifGeneratingDynamicToo DynFlags
dflags CompPipeline FilePath
dynToo CompPipeline FilePath
noDynToo
PhasePlus
_ -> PhasePlus -> FilePath -> CompPipeline FilePath
pipeLoop PhasePlus
next_phase FilePath
output_fn
runHookedPhase :: PhasePlus -> FilePath -> DynFlags
-> CompPipeline (PhasePlus, FilePath)
runHookedPhase :: PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
runHookedPhase PhasePlus
pp FilePath
input DynFlags
dflags =
(Hooks
-> Maybe
(PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)))
-> (PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
-> DynFlags
-> PhasePlus
-> FilePath
-> DynFlags
-> CompPipeline (PhasePlus, FilePath)
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks
-> Maybe
(PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
runPhaseHook PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
runPhase DynFlags
dflags PhasePlus
pp FilePath
input DynFlags
dflags
phaseOutputFilename :: Phase -> CompPipeline FilePath
phaseOutputFilename :: Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase = do
PipeEnv{Phase
stop_phase :: Phase
stop_phase :: PipeEnv -> Phase
stop_phase, FilePath
src_basename :: FilePath
src_basename :: PipeEnv -> FilePath
src_basename, PipelineOutput
output_spec :: PipelineOutput
output_spec :: PipeEnv -> PipelineOutput
output_spec} <- CompPipeline PipeEnv
getPipeEnv
PipeState{Maybe ModLocation
maybe_loc :: Maybe ModLocation
maybe_loc :: PipeState -> Maybe ModLocation
maybe_loc, HscEnv
hsc_env :: HscEnv
hsc_env :: PipeState -> HscEnv
hsc_env} <- CompPipeline PipeState
getPipeState
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
IO FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> CompPipeline FilePath)
-> IO FilePath -> CompPipeline FilePath
forall a b. (a -> b) -> a -> b
$ Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename Phase
stop_phase PipelineOutput
output_spec
FilePath
src_basename DynFlags
dflags Phase
next_phase Maybe ModLocation
maybe_loc
getOutputFilename
:: Phase -> PipelineOutput -> String
-> DynFlags -> Phase -> Maybe ModLocation -> IO FilePath
getOutputFilename :: Phase
-> PipelineOutput
-> FilePath
-> DynFlags
-> Phase
-> Maybe ModLocation
-> IO FilePath
getOutputFilename Phase
stop_phase PipelineOutput
output FilePath
basename DynFlags
dflags Phase
next_phase Maybe ModLocation
maybe_location
| Bool
is_last_phase, PipelineOutput
Persistent <- PipelineOutput
output = IO FilePath
persistent_fn
| Bool
is_last_phase, PipelineOutput
SpecificFile <- PipelineOutput
output = case DynFlags -> Maybe FilePath
outputFile DynFlags
dflags of
Just FilePath
f -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f
Maybe FilePath
Nothing ->
FilePath -> IO FilePath
forall a. FilePath -> a
panic FilePath
"SpecificFile: No filename"
| Bool
keep_this_output = IO FilePath
persistent_fn
| Temporary TempFileLifetime
lifetime <- PipelineOutput
output = DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
lifetime FilePath
suffix
| Bool
otherwise = DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule
FilePath
suffix
where
hcsuf :: FilePath
hcsuf = DynFlags -> FilePath
hcSuf DynFlags
dflags
odir :: Maybe FilePath
odir = DynFlags -> Maybe FilePath
objectDir DynFlags
dflags
osuf :: FilePath
osuf = DynFlags -> FilePath
objectSuf DynFlags
dflags
keep_hc :: Bool
keep_hc = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepHcFiles DynFlags
dflags
keep_hscpp :: Bool
keep_hscpp = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepHscppFiles DynFlags
dflags
keep_s :: Bool
keep_s = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepSFiles DynFlags
dflags
keep_bc :: Bool
keep_bc = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepLlvmFiles DynFlags
dflags
myPhaseInputExt :: Phase -> FilePath
myPhaseInputExt Phase
HCc = FilePath
hcsuf
myPhaseInputExt Phase
MergeForeign = FilePath
osuf
myPhaseInputExt Phase
StopLn = FilePath
osuf
myPhaseInputExt Phase
other = Phase -> FilePath
phaseInputExt Phase
other
is_last_phase :: Bool
is_last_phase = Phase
next_phase Phase -> Phase -> Bool
`eqPhase` Phase
stop_phase
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
Phase
_other -> Bool
False
suffix :: FilePath
suffix = Phase -> FilePath
myPhaseInputExt Phase
next_phase
persistent_fn :: IO FilePath
persistent_fn
| Phase
StopLn <- Phase
next_phase = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
odir_persistent
| Bool
otherwise = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
persistent
persistent :: FilePath
persistent = FilePath
basename FilePath -> FilePath -> FilePath
<.> FilePath
suffix
odir_persistent :: FilePath
odir_persistent
| Just ModLocation
loc <- Maybe ModLocation
maybe_location = ModLocation -> FilePath
ml_obj_file ModLocation
loc
| Just FilePath
d <- Maybe FilePath
odir = FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
persistent
| Bool
otherwise = FilePath
persistent
llvmOptions :: DynFlags
-> [(String, String)]
llvmOptions :: DynFlags -> [(FilePath, FilePath)]
llvmOptions DynFlags
dflags =
[(FilePath
"-enable-tbaa -tbaa", FilePath
"-enable-tbaa") | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LlvmTBAA DynFlags
dflags ]
[(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath
"-relocation-model=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
rmodel
,FilePath
"-relocation-model=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
rmodel) | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
rmodel)]
[(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath
"-stack-alignment=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
align)
,FilePath
"-stack-alignment=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
align)) | Int
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ]
[(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath
"", FilePath
"-mcpu=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mcpu) | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
mcpu)
, Bool -> Bool
not ((FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf FilePath
"-mcpu") (DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_lc)) ]
[(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath
"", FilePath
"-mattr=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
attrs) | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
attrs) ]
where target :: FilePath
target = PlatformMisc -> FilePath
platformMisc_llvmTarget (PlatformMisc -> FilePath) -> PlatformMisc -> FilePath
forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
Just (LlvmTarget FilePath
_ FilePath
mcpu [FilePath]
mattr) = FilePath -> [(FilePath, LlvmTarget)] -> Maybe LlvmTarget
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
target (LlvmConfig -> [(FilePath, LlvmTarget)]
llvmTargets (LlvmConfig -> [(FilePath, LlvmTarget)])
-> LlvmConfig -> [(FilePath, LlvmTarget)]
forall a b. (a -> b) -> a -> b
$ DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags)
rmodel :: FilePath
rmodel | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PIC DynFlags
dflags = FilePath
"pic"
| DynFlags -> Bool
positionIndependent DynFlags
dflags = FilePath
"pic"
| Way
WayDyn Way -> Set Way -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> Set Way
ways DynFlags
dflags = FilePath
"dynamic-no-pic"
| Bool
otherwise = FilePath
"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 :: FilePath
attrs = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath]
mattr
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+sse42" | DynFlags -> Bool
isSse4_2Enabled DynFlags
dflags ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+sse2" | Platform -> Bool
isSse2Enabled Platform
platform ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+sse" | Platform -> Bool
isSseEnabled Platform
platform ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+avx512f" | DynFlags -> Bool
isAvx512fEnabled DynFlags
dflags ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+avx2" | DynFlags -> Bool
isAvx2Enabled DynFlags
dflags ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+avx" | DynFlags -> Bool
isAvxEnabled DynFlags
dflags ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+avx512cd"| DynFlags -> Bool
isAvx512cdEnabled DynFlags
dflags ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+avx512er"| DynFlags -> Bool
isAvx512erEnabled DynFlags
dflags ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+avx512pf"| DynFlags -> Bool
isAvx512pfEnabled DynFlags
dflags ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+bmi" | DynFlags -> Bool
isBmiEnabled DynFlags
dflags ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"+bmi2" | DynFlags -> Bool
isBmi2Enabled DynFlags
dflags ]
runPhase :: PhasePlus
-> FilePath
-> DynFlags
-> CompPipeline (PhasePlus,
FilePath)
runPhase :: PhasePlus
-> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)
runPhase (RealPhase (Unlit HscSource
sf)) FilePath
input_fn DynFlags
dflags
= do
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename (HscSource -> Phase
Cpp HscSource
sf)
let flags :: [Option]
flags = [
FilePath -> Option
GHC.SysTools.Option FilePath
"-h"
, FilePath -> Option
GHC.SysTools.Option (FilePath -> Option) -> FilePath -> Option
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
escape FilePath
input_fn
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
input_fn
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn
]
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
GHC.SysTools.runUnlit DynFlags
dflags [Option]
flags
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Cpp HscSource
sf), FilePath
output_fn)
where
escape :: FilePath -> FilePath
escape (Char
'\\':FilePath
cs) = Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
escape FilePath
cs
escape (Char
'\"':FilePath
cs) = Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'\"'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
escape FilePath
cs
escape (Char
'\'':FilePath
cs) = Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Char
'\''Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
escape FilePath
cs
escape (Char
c:FilePath
cs) = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
escape FilePath
cs
escape [] = []
runPhase (RealPhase (Cpp HscSource
sf)) FilePath
input_fn DynFlags
dflags0
= do
[Located FilePath]
src_opts <- IO [Located FilePath] -> CompPipeline [Located FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located FilePath] -> CompPipeline [Located FilePath])
-> IO [Located FilePath] -> CompPipeline [Located FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO [Located FilePath]
getOptionsFromFile DynFlags
dflags0 FilePath
input_fn
(DynFlags
dflags1, [Located FilePath]
unhandled_flags, [Warn]
warns)
<- IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn]))
-> IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
src_opts
DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags1
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Located FilePath] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located FilePath] -> m ()
checkProcessArgsResult DynFlags
dflags1 [Located FilePath]
unhandled_flags
if Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.Cpp DynFlags
dflags1) then do
Bool -> CompPipeline () -> CompPipeline ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags1) (CompPipeline () -> CompPipeline ())
-> CompPipeline () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags1 [Warn]
warns
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
HsPp HscSource
sf), FilePath
input_fn)
else do
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename (HscSource -> Phase
HsPp HscSource
sf)
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp DynFlags
dflags1 Bool
True
FilePath
input_fn FilePath
output_fn
[Located FilePath]
src_opts <- IO [Located FilePath] -> CompPipeline [Located FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located FilePath] -> CompPipeline [Located FilePath])
-> IO [Located FilePath] -> CompPipeline [Located FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO [Located FilePath]
getOptionsFromFile DynFlags
dflags0 FilePath
output_fn
(DynFlags
dflags2, [Located FilePath]
unhandled_flags, [Warn]
warns)
<- IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn]))
-> IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
src_opts
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Located FilePath] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located FilePath] -> m ()
checkProcessArgsResult DynFlags
dflags2 [Located FilePath]
unhandled_flags
Bool -> CompPipeline () -> CompPipeline ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags2) (CompPipeline () -> CompPipeline ())
-> CompPipeline () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags2 [Warn]
warns
DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags2
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
HsPp HscSource
sf), FilePath
output_fn)
runPhase (RealPhase (HsPp HscSource
sf)) FilePath
input_fn DynFlags
dflags
= if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags) then
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Hsc HscSource
sf), FilePath
input_fn)
else do
PipeEnv{FilePath
src_basename :: FilePath
src_basename :: PipeEnv -> FilePath
src_basename, FilePath
src_suffix :: FilePath
src_suffix :: PipeEnv -> FilePath
src_suffix} <- CompPipeline PipeEnv
getPipeEnv
let orig_fn :: FilePath
orig_fn = FilePath
src_basename FilePath -> FilePath -> FilePath
<.> FilePath
src_suffix
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename (HscSource -> Phase
Hsc HscSource
sf)
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
GHC.SysTools.runPp DynFlags
dflags
( [ FilePath -> Option
GHC.SysTools.Option FilePath
orig_fn
, FilePath -> Option
GHC.SysTools.Option FilePath
input_fn
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn
]
)
[Located FilePath]
src_opts <- IO [Located FilePath] -> CompPipeline [Located FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Located FilePath] -> CompPipeline [Located FilePath])
-> IO [Located FilePath] -> CompPipeline [Located FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO [Located FilePath]
getOptionsFromFile DynFlags
dflags FilePath
output_fn
(DynFlags
dflags1, [Located FilePath]
unhandled_flags, [Warn]
warns)
<- IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn]))
-> IO (DynFlags, [Located FilePath], [Warn])
-> CompPipeline (DynFlags, [Located FilePath], [Warn])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags [Located FilePath]
src_opts
DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags1
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Located FilePath] -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located FilePath] -> m ()
checkProcessArgsResult DynFlags
dflags1 [Located FilePath]
unhandled_flags
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Warn] -> IO ()
handleFlagWarnings DynFlags
dflags1 [Warn]
warns
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase (HscSource -> Phase
Hsc HscSource
sf), FilePath
output_fn)
runPhase (RealPhase (Hsc HscSource
src_flavour)) FilePath
input_fn DynFlags
dflags0
= do
PipeEnv{ stop_phase :: PipeEnv -> Phase
stop_phase=Phase
stop,
src_basename :: PipeEnv -> FilePath
src_basename=FilePath
basename,
src_suffix :: PipeEnv -> FilePath
src_suffix=FilePath
suff } <- CompPipeline PipeEnv
getPipeEnv
let current_dir :: FilePath
current_dir = FilePath -> FilePath
takeDirectory FilePath
basename
new_includes :: IncludeSpecs
new_includes = IncludeSpecs -> [FilePath] -> IncludeSpecs
addQuoteInclude IncludeSpecs
paths [FilePath
current_dir]
paths :: IncludeSpecs
paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags0
dflags :: DynFlags
dflags = DynFlags
dflags0 { includePaths :: IncludeSpecs
includePaths = IncludeSpecs
new_includes }
DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags
(Maybe InputFileBuffer
hspp_buf,ModuleName
mod_name,[(Maybe FastString, Located ModuleName)]
imps,[(Maybe FastString, Located ModuleName)]
src_imps) <- IO
(Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)])
-> CompPipeline
(Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)])
-> CompPipeline
(Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)]))
-> IO
(Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)])
-> CompPipeline
(Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)])
forall a b. (a -> b) -> a -> b
$ do
InputFileBuffer
buf <- FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
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 Error)
([(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)], Located ModuleName)
eimps <- ParserOpts
-> Bool
-> InputFileBuffer
-> FilePath
-> FilePath
-> IO
(Either
(Bag Error)
([(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)], Located ModuleName))
getImports ParserOpts
popts Bool
imp_prelude InputFileBuffer
buf FilePath
input_fn (FilePath
basename FilePath -> FilePath -> FilePath
<.> FilePath
suff)
case Either
(Bag Error)
([(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)], Located ModuleName)
eimps of
Left Bag Error
errs -> ErrorMessages
-> IO
(Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)])
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ((Error -> ErrMsg) -> Bag Error -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Error -> ErrMsg
pprError Bag Error
errs)
Right ([(Maybe FastString, Located ModuleName)]
src_imps,[(Maybe FastString, Located ModuleName)]
imps,L SrcSpan
_ ModuleName
mod_name) -> (Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)])
-> IO
(Maybe InputFileBuffer, ModuleName,
[(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)])
forall (m :: * -> *) a. Monad m => a -> m a
return
(InputFileBuffer -> Maybe InputFileBuffer
forall a. a -> Maybe a
Just InputFileBuffer
buf, ModuleName
mod_name, [(Maybe FastString, Located ModuleName)]
imps, [(Maybe FastString, Located ModuleName)]
src_imps)
ModLocation
location <- HscSource -> ModuleName -> CompPipeline ModLocation
getLocation HscSource
src_flavour ModuleName
mod_name
let o_file :: FilePath
o_file = ModLocation -> FilePath
ml_obj_file ModLocation
location
hi_file :: FilePath
hi_file = ModLocation -> FilePath
ml_hi_file ModLocation
location
hie_file :: FilePath
hie_file = ModLocation -> FilePath
ml_hie_file ModLocation
location
dest_file :: FilePath
dest_file | DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags
= FilePath
hi_file
| Bool
otherwise
= FilePath
o_file
UTCTime
src_timestamp <- IO UTCTime -> CompPipeline UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> CompPipeline UTCTime)
-> IO UTCTime -> CompPipeline UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime (FilePath
basename FilePath -> FilePath -> FilePath
<.> FilePath
suff)
SourceModified
source_unchanged <- IO SourceModified -> CompPipeline SourceModified
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SourceModified -> CompPipeline SourceModified)
-> IO SourceModified -> CompPipeline SourceModified
forall a b. (a -> b) -> a -> b
$
if Bool -> Bool
not (Phase -> Bool
isStopLn Phase
stop)
then SourceModified -> IO SourceModified
forall (m :: * -> *) a. Monad m => a -> m a
return SourceModified
SourceModified
else do Bool
dest_file_mod <- FilePath -> UTCTime -> IO Bool
sourceModified FilePath
dest_file UTCTime
src_timestamp
Bool
hie_file_mod <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags
then FilePath -> UTCTime -> IO Bool
sourceModified FilePath
hie_file
UTCTime
src_timestamp
else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
if Bool
dest_file_mod Bool -> Bool -> Bool
|| Bool
hie_file_mod
then SourceModified -> IO SourceModified
forall (m :: * -> *) a. Monad m => a -> m a
return SourceModified
SourceModified
else SourceModified -> IO SourceModified
forall (m :: * -> *) a. Monad m => a -> m a
return SourceModified
SourceUnmodified
PipeState{hsc_env :: PipeState -> HscEnv
hsc_env=HscEnv
hsc_env'} <- CompPipeline PipeState
getPipeState
Module
mod <- IO Module -> CompPipeline Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> CompPipeline Module)
-> IO Module -> CompPipeline Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env' ModuleName
mod_name ModLocation
location
let
mod_summary :: ModSummary
mod_summary = ModSummary :: Module
-> HscSource
-> ModLocation
-> UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> Maybe HsParsedModule
-> FilePath
-> DynFlags
-> Maybe InputFileBuffer
-> ModSummary
ModSummary { ms_mod :: Module
ms_mod = Module
mod,
ms_hsc_src :: HscSource
ms_hsc_src = HscSource
src_flavour,
ms_hspp_file :: FilePath
ms_hspp_file = FilePath
input_fn,
ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags,
ms_hspp_buf :: Maybe InputFileBuffer
ms_hspp_buf = Maybe InputFileBuffer
hspp_buf,
ms_location :: ModLocation
ms_location = ModLocation
location,
ms_hs_date :: UTCTime
ms_hs_date = UTCTime
src_timestamp,
ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
forall a. Maybe a
Nothing,
ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = Maybe HsParsedModule
forall a. Maybe a
Nothing,
ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
forall a. Maybe a
Nothing,
ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
forall a. Maybe a
Nothing,
ms_textual_imps :: [(Maybe FastString, Located ModuleName)]
ms_textual_imps = [(Maybe FastString, Located ModuleName)]
imps,
ms_srcimps :: [(Maybe FastString, Located ModuleName)]
ms_srcimps = [(Maybe FastString, Located ModuleName)]
src_imps }
let msg :: HscEnv -> p -> RecompileRequired -> p -> IO ()
msg HscEnv
hsc_env p
_ RecompileRequired
what p
_ = HscEnv -> RecompileRequired -> IO ()
oneShotMsg HscEnv
hsc_env RecompileRequired
what
(HscStatus
result, DynFlags
plugin_dflags) <-
IO (HscStatus, DynFlags) -> CompPipeline (HscStatus, DynFlags)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HscStatus, DynFlags) -> CompPipeline (HscStatus, DynFlags))
-> IO (HscStatus, DynFlags) -> CompPipeline (HscStatus, DynFlags)
forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, DynFlags)
hscIncrementalCompile Bool
True Maybe TcGblEnv
forall a. Maybe a
Nothing (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
forall p p. HscEnv -> p -> RecompileRequired -> p -> IO ()
msg) HscEnv
hsc_env'
ModSummary
mod_summary SourceModified
source_unchanged Maybe ModIface
forall a. Maybe a
Nothing (Int
1,Int
1)
DynFlags -> CompPipeline ()
setDynFlags DynFlags
plugin_dflags
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscSource -> ModuleName -> HscStatus -> PhasePlus
HscOut HscSource
src_flavour ModuleName
mod_name HscStatus
result,
FilePath -> FilePath
forall a. FilePath -> a
panic FilePath
"HscOut doesn't have an input filename")
runPhase (HscOut HscSource
src_flavour ModuleName
mod_name HscStatus
result) FilePath
_ DynFlags
dflags = do
ModLocation
location <- HscSource -> ModuleName -> CompPipeline ModLocation
getLocation HscSource
src_flavour ModuleName
mod_name
ModLocation -> CompPipeline ()
setModLocation ModLocation
location
let o_file :: FilePath
o_file = ModLocation -> FilePath
ml_obj_file ModLocation
location
next_phase :: Phase
next_phase = HscSource -> Backend -> Phase
hscPostBackendPhase HscSource
src_flavour (DynFlags -> Backend
backend DynFlags
dflags)
case HscStatus
result of
HscNotGeneratingCode ModIface
_ ModDetails
_ ->
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn,
FilePath -> FilePath
forall a. FilePath -> a
panic FilePath
"No output filename from Hsc when no-code")
HscUpToDate ModIface
_ ModDetails
_ ->
do IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO ()
touchObjectFile DynFlags
dflags FilePath
o_file
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, FilePath
o_file)
HscUpdateBoot ModIface
_ ModDetails
_ ->
do
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO ()
touchObjectFile DynFlags
dflags FilePath
o_file
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, FilePath
o_file)
HscUpdateSig ModIface
_ ModDetails
_ ->
do
PipeState{hsc_env :: PipeState -> HscEnv
hsc_env=HscEnv
hsc_env'} <- CompPipeline PipeState
getPipeState
let input_fn :: FilePath
input_fn = FilePath -> Maybe FilePath -> FilePath
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"runPhase" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location)
basename :: FilePath
basename = FilePath -> FilePath
dropExtension FilePath
input_fn
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub DynFlags
dflags HscEnv
hsc_env' FilePath
basename ModLocation
location ModuleName
mod_name
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, FilePath
o_file)
HscRecomp { hscs_guts :: HscStatus -> CgGuts
hscs_guts = CgGuts
cgguts,
hscs_mod_location :: HscStatus -> ModLocation
hscs_mod_location = ModLocation
mod_location,
hscs_mod_details :: HscStatus -> ModDetails
hscs_mod_details = ModDetails
mod_details,
hscs_partial_iface :: HscStatus -> PartialModIface
hscs_partial_iface = PartialModIface
partial_iface,
hscs_old_iface_hash :: HscStatus -> Maybe Fingerprint
hscs_old_iface_hash = Maybe Fingerprint
mb_old_iface_hash,
hscs_iface_dflags :: HscStatus -> DynFlags
hscs_iface_dflags = DynFlags
iface_dflags }
-> do FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase
PipeState{hsc_env :: PipeState -> HscEnv
hsc_env=HscEnv
hsc_env'} <- CompPipeline PipeState
getPipeState
(FilePath
outputFilename, Maybe FilePath
mStub, [(ForeignSrcLang, FilePath)]
foreign_files, CgInfos
cg_infos) <- IO
(FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
-> CompPipeline
(FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
-> CompPipeline
(FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos))
-> IO
(FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
-> CompPipeline
(FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
forall a b. (a -> b) -> a -> b
$
HscEnv
-> CgGuts
-> ModLocation
-> FilePath
-> IO
(FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
hscGenHardCode HscEnv
hsc_env' CgGuts
cgguts ModLocation
mod_location FilePath
output_fn
ModIface
final_iface <- IO ModIface -> CompPipeline ModIface
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface
mkFullIface HscEnv
hsc_env'{hsc_dflags :: DynFlags
hsc_dflags=DynFlags
iface_dflags} PartialModIface
partial_iface (CgInfos -> Maybe CgInfos
forall a. a -> Maybe a
Just CgInfos
cg_infos))
let final_mod_details :: ModDetails
final_mod_details
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
iface_dflags
= ModDetails
mod_details
| Bool
otherwise = {-# SCC updateModDetailsIdInfos #-}
CgInfos -> ModDetails -> ModDetails
updateModDetailsIdInfos CgInfos
cg_infos ModDetails
mod_details
ModIface -> ModDetails -> CompPipeline ()
setIface ModIface
final_iface ModDetails
final_mod_details
let if_dflags :: DynFlags
if_dflags = DynFlags
dflags DynFlags -> GeneralFlag -> DynFlags
`gopt_unset` GeneralFlag
Opt_BuildDynamicToo
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()
hscMaybeWriteIface DynFlags
if_dflags ModIface
final_iface Maybe Fingerprint
mb_old_iface_hash ModLocation
mod_location
Maybe FilePath
stub_o <- IO (Maybe FilePath) -> CompPipeline (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((FilePath -> IO FilePath) -> Maybe FilePath -> IO (Maybe FilePath)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HscEnv -> FilePath -> IO FilePath
compileStub HscEnv
hsc_env') Maybe FilePath
mStub)
[FilePath]
foreign_os <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$
((ForeignSrcLang, FilePath) -> IO FilePath)
-> [(ForeignSrcLang, FilePath)] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ForeignSrcLang -> FilePath -> IO FilePath)
-> (ForeignSrcLang, FilePath) -> IO FilePath
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign HscEnv
hsc_env')) [(ForeignSrcLang, FilePath)]
foreign_files
[FilePath] -> CompPipeline ()
setForeignOs ([FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] FilePath -> [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
stub_o [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
foreign_os)
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
outputFilename)
runPhase (RealPhase Phase
CmmCpp) FilePath
input_fn DynFlags
dflags
= do FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
Cmm
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp DynFlags
dflags Bool
False
FilePath
input_fn FilePath
output_fn
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
Cmm, FilePath
output_fn)
runPhase (RealPhase Phase
Cmm) FilePath
input_fn DynFlags
dflags
= do let next_phase :: Phase
next_phase = HscSource -> Backend -> Phase
hscPostBackendPhase HscSource
HsSrcFile (DynFlags -> Backend
backend DynFlags
dflags)
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase
PipeState{HscEnv
hsc_env :: HscEnv
hsc_env :: PipeState -> HscEnv
hsc_env} <- CompPipeline PipeState
getPipeState
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> FilePath -> FilePath -> IO ()
hscCompileCmmFile HscEnv
hsc_env FilePath
input_fn FilePath
output_fn
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)
runPhase (RealPhase Phase
cc_phase) FilePath
input_fn DynFlags
dflags
| (Phase -> Bool) -> [Phase] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Phase
cc_phase Phase -> Phase -> Bool
`eqPhase`) [Phase
Cc, Phase
Ccxx, Phase
HCc, Phase
Cobjc, Phase
Cobjcxx]
= do
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
hcc :: Bool
hcc = Phase
cc_phase Phase -> Phase -> Bool
`eqPhase` Phase
HCc
home_unit :: HomeUnit
home_unit = DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags
let cmdline_include_paths :: IncludeSpecs
cmdline_include_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags
[UnitId]
pkgs <- if Bool
hcc then IO [UnitId] -> CompPipeline [UnitId]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [UnitId] -> CompPipeline [UnitId])
-> IO [UnitId] -> CompPipeline [UnitId]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [UnitId]
getHCFilePackages FilePath
input_fn else [UnitId] -> CompPipeline [UnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[FilePath]
pkg_include_dirs <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$ SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitIncludePath
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
HomeUnit
home_unit
[UnitId]
pkgs
let include_paths_global :: [FilePath]
include_paths_global = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ FilePath
x [FilePath]
xs -> (FilePath
"-I" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
(IncludeSpecs -> [FilePath]
includePathsGlobal IncludeSpecs
cmdline_include_paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_include_dirs)
let include_paths_quote :: [FilePath]
include_paths_quote = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ FilePath
x [FilePath]
xs -> (FilePath
"-iquote" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
(IncludeSpecs -> [FilePath]
includePathsQuote IncludeSpecs
cmdline_include_paths)
let include_paths :: [FilePath]
include_paths = [FilePath]
include_paths_quote [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
include_paths_global
let more_preprocessor_opts :: [FilePath]
more_preprocessor_opts = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [FilePath
"-Xpreprocessor", FilePath
i]
| Bool -> Bool
not Bool
hcc
, FilePath
i <- DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_P
]
let gcc_extra_viac_flags :: [FilePath]
gcc_extra_viac_flags = DynFlags -> [FilePath]
extraGccViaCFlags DynFlags
dflags
let pic_c_flags :: [FilePath]
pic_c_flags = DynFlags -> [FilePath]
picCCOpts DynFlags
dflags
let verbFlags :: [FilePath]
verbFlags = DynFlags -> [FilePath]
getVerbFlags DynFlags
dflags
[FilePath]
pkg_extra_cc_opts <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$
if Bool
hcc
then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitExtraCcOpts
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
HomeUnit
home_unit
[UnitId]
pkgs
[FilePath]
framework_paths <-
if Platform -> Bool
platformUsesFrameworks Platform
platform
then do [FilePath]
pkgFrameworkPaths <- IO [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CompPipeline [FilePath])
-> IO [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$ SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworkPath
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
HomeUnit
home_unit
[UnitId]
pkgs
let cmdlineFrameworkPaths :: [FilePath]
cmdlineFrameworkPaths = DynFlags -> [FilePath]
frameworkPaths DynFlags
dflags
[FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> CompPipeline [FilePath])
-> [FilePath] -> CompPipeline [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-F"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)
([FilePath]
cmdlineFrameworkPaths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkgFrameworkPaths)
else [FilePath] -> CompPipeline [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
let cc_opt :: [FilePath]
cc_opt | DynFlags -> Int
optLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 = [ FilePath
"-O2" ]
| DynFlags -> Int
optLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 = [ FilePath
"-O" ]
| Bool
otherwise = []
let next_phase :: Phase
next_phase = Bool -> Phase
As Bool
False
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase
let
more_hcc_opts :: [FilePath]
more_hcc_opts =
(if Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchX86 Bool -> Bool -> Bool
&&
Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExcessPrecision DynFlags
dflags)
then [ FilePath
"-ffloat-store" ]
else []) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[FilePath
"-fno-strict-aliasing"]
FilePath
ghcVersionH <- IO FilePath -> CompPipeline FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> CompPipeline FilePath)
-> IO FilePath -> CompPipeline FilePath
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO FilePath
getGhcVersionPathName DynFlags
dflags
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runCc (Phase -> Maybe ForeignSrcLang
phaseForeignLanguage Phase
cc_phase) DynFlags
dflags (
[ FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
input_fn
, FilePath -> Option
GHC.SysTools.Option FilePath
"-o"
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn
]
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option (
[FilePath]
pic_c_flags
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 Bool -> Bool -> Bool
&&
HomeUnit -> UnitId -> Bool
forall u. GenHomeUnit u -> UnitId -> Bool
isHomeUnitId HomeUnit
home_unit UnitId
baseUnitId
then [ FilePath
"-DCOMPILING_BASE_PACKAGE" ]
else [])
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchSPARC
then [FilePath
"-mcpu=v9"]
else [])
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if (Phase
cc_phase Phase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
/= Phase
Ccxx Bool -> Bool -> Bool
&& Phase
cc_phase Phase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
/= Phase
Cobjcxx)
then [FilePath
"-Wimplicit"]
else [])
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Bool
hcc
then [FilePath]
gcc_extra_viac_flags [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
more_hcc_opts
else [])
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
verbFlags
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ FilePath
"-S" ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
cc_opt
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ FilePath
"-include", FilePath
ghcVersionH ]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
framework_paths
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
include_paths
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
more_preprocessor_opts
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_extra_cc_opts
))
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)
runPhase (RealPhase (As Bool
with_cpp)) FilePath
input_fn DynFlags
dflags
= do
let as_prog :: DynFlags -> [Option] -> IO ()
as_prog | DynFlags -> Backend
backend DynFlags
dflags Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
== Backend
LLVM Bool -> Bool -> Bool
&&
Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
= DynFlags -> [Option] -> IO ()
GHC.SysTools.runClang
| Bool
otherwise = DynFlags -> [Option] -> IO ()
GHC.SysTools.runAs
let cmdline_include_paths :: IncludeSpecs
cmdline_include_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags
let pic_c_flags :: [FilePath]
pic_c_flags = DynFlags -> [FilePath]
picCCOpts DynFlags
dflags
Phase
next_phase <- CompPipeline Phase
maybeMergeForeign
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
output_fn)
CompilerInfo
ccInfo <- IO CompilerInfo -> CompPipeline CompilerInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CompilerInfo -> CompPipeline CompilerInfo)
-> IO CompilerInfo -> CompPipeline CompilerInfo
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO CompilerInfo
getCompilerInfo DynFlags
dflags
let global_includes :: [Option]
global_includes = [ FilePath -> Option
GHC.SysTools.Option (FilePath
"-I" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p)
| FilePath
p <- IncludeSpecs -> [FilePath]
includePathsGlobal IncludeSpecs
cmdline_include_paths ]
let local_includes :: [Option]
local_includes = [ FilePath -> Option
GHC.SysTools.Option (FilePath
"-iquote" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p)
| FilePath
p <- IncludeSpecs -> [FilePath]
includePathsQuote IncludeSpecs
cmdline_include_paths ]
let runAssembler :: FilePath -> FilePath -> CompPipeline ()
runAssembler FilePath
inputFilename FilePath
outputFilename
= IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$
FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
FilePath -> (FilePath -> m a) -> m a
withAtomicRename FilePath
outputFilename ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
temp_outputFilename ->
DynFlags -> [Option] -> IO ()
as_prog
DynFlags
dflags
([Option]
local_includes [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
global_includes
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
pic_c_flags
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
GHC.SysTools.Option FilePath
"-Wa,-mbig-obj"
| Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
]
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (if Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchSPARC
then [FilePath -> Option
GHC.SysTools.Option FilePath
"-mcpu=v9"]
else [])
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (if (CompilerInfo -> Bool) -> [CompilerInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CompilerInfo
ccInfo CompilerInfo -> CompilerInfo -> Bool
forall a. Eq a => a -> a -> Bool
==) [CompilerInfo
Clang, CompilerInfo
AppleClang, CompilerInfo
AppleClang51]
then [FilePath -> Option
GHC.SysTools.Option FilePath
"-Qunused-arguments"]
else [])
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
GHC.SysTools.Option FilePath
"-x"
, if Bool
with_cpp
then FilePath -> Option
GHC.SysTools.Option FilePath
"assembler-with-cpp"
else FilePath -> Option
GHC.SysTools.Option FilePath
"assembler"
, FilePath -> Option
GHC.SysTools.Option FilePath
"-c"
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
inputFilename
, FilePath -> Option
GHC.SysTools.Option FilePath
"-o"
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
temp_outputFilename
])
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
4 (FilePath -> SDoc
text FilePath
"Running the assembler")
FilePath -> FilePath -> CompPipeline ()
runAssembler FilePath
input_fn FilePath
output_fn
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)
runPhase (RealPhase Phase
LlvmOpt) FilePath
input_fn DynFlags
dflags
= do
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
LlvmLlc
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
GHC.SysTools.runLlvmOpt DynFlags
dflags
( [Option]
optFlag
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
defaultOptions [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++
[ FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
input_fn
, FilePath -> Option
GHC.SysTools.Option FilePath
"-o"
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn]
)
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
LlvmLlc, FilePath
output_fn)
where
optIdx :: Int
optIdx = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int
optLevel DynFlags
dflags
llvmOpts :: FilePath
llvmOpts = case Int -> [(Int, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
optIdx ([(Int, FilePath)] -> Maybe FilePath)
-> [(Int, FilePath)] -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ LlvmConfig -> [(Int, FilePath)]
llvmPasses (LlvmConfig -> [(Int, FilePath)])
-> LlvmConfig -> [(Int, FilePath)]
forall a b. (a -> b) -> a -> b
$ DynFlags -> LlvmConfig
llvmConfig DynFlags
dflags of
Just FilePath
passes -> FilePath
passes
Maybe FilePath
Nothing -> FilePath -> FilePath
forall a. FilePath -> a
panic (FilePath
"runPhase LlvmOpt: llvm-passes file "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"is missing passes for level "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
optIdx)
optFlag :: [Option]
optFlag = if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_lo)
then (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
words FilePath
llvmOpts
else []
defaultOptions :: [Option]
defaultOptions = (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option ([FilePath] -> [Option])
-> (([FilePath], [FilePath]) -> [FilePath])
-> ([FilePath], [FilePath])
-> [Option]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath])
-> (([FilePath], [FilePath]) -> [[FilePath]])
-> ([FilePath], [FilePath])
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
words ([FilePath] -> [[FilePath]])
-> (([FilePath], [FilePath]) -> [FilePath])
-> ([FilePath], [FilePath])
-> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath], [FilePath]) -> [FilePath]
forall a b. (a, b) -> a
fst
(([FilePath], [FilePath]) -> [Option])
-> ([FilePath], [FilePath]) -> [Option]
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> ([FilePath], [FilePath])
forall a b. [(a, b)] -> ([a], [b])
unzip (DynFlags -> [(FilePath, FilePath)]
llvmOptions DynFlags
dflags)
runPhase (RealPhase Phase
LlvmLlc) FilePath
input_fn DynFlags
dflags
= do
Phase
next_phase <- if
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoLlvmMangler DynFlags
dflags -> Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Phase
As Bool
False)
| Bool
otherwise -> Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return Phase
LlvmMangle
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Option] -> IO ()
GHC.SysTools.runLlvmLlc DynFlags
dflags
( [Option]
optFlag
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
defaultOptions
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
input_fn
, FilePath -> Option
GHC.SysTools.Option FilePath
"-o"
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn
]
)
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)
where
llvmOpts :: FilePath
llvmOpts = case DynFlags -> Int
optLevel DynFlags
dflags of
Int
0 -> FilePath
"-O1"
Int
1 -> FilePath
"-O1"
Int
_ -> FilePath
"-O2"
optFlag :: [Option]
optFlag = if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> (DynFlags -> [FilePath]) -> [FilePath]
forall a. DynFlags -> (DynFlags -> [a]) -> [a]
getOpts DynFlags
dflags DynFlags -> [FilePath]
opt_lc)
then (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
words FilePath
llvmOpts
else []
defaultOptions :: [Option]
defaultOptions = (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option ([FilePath] -> [Option])
-> (([FilePath], [FilePath]) -> [FilePath])
-> ([FilePath], [FilePath])
-> [Option]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> [FilePath]
words ([FilePath] -> [FilePath])
-> (([FilePath], [FilePath]) -> [FilePath])
-> ([FilePath], [FilePath])
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath], [FilePath]) -> [FilePath]
forall a b. (a, b) -> b
snd
(([FilePath], [FilePath]) -> [Option])
-> ([FilePath], [FilePath]) -> [Option]
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> ([FilePath], [FilePath])
forall a b. [(a, b)] -> ([a], [b])
unzip (DynFlags -> [(FilePath, FilePath)]
llvmOptions DynFlags
dflags)
runPhase (RealPhase Phase
LlvmMangle) FilePath
input_fn DynFlags
dflags
= do
let next_phase :: Phase
next_phase = Bool -> Phase
As Bool
False
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
next_phase
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> FilePath -> IO ()
llvmFixupAsm DynFlags
dflags FilePath
input_fn FilePath
output_fn
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
next_phase, FilePath
output_fn)
runPhase (RealPhase Phase
MergeForeign) FilePath
input_fn DynFlags
dflags
= do
PipeState{[FilePath]
foreign_os :: [FilePath]
foreign_os :: PipeState -> [FilePath]
foreign_os} <- CompPipeline PipeState
getPipeState
FilePath
output_fn <- Phase -> CompPipeline FilePath
phaseOutputFilename Phase
StopLn
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
output_fn)
if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
foreign_os
then FilePath -> CompPipeline (PhasePlus, FilePath)
forall a. FilePath -> a
panic FilePath
"runPhase(MergeForeign): no foreign objects"
else do
IO () -> CompPipeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CompPipeline ()) -> IO () -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles DynFlags
dflags (FilePath
input_fn FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
foreign_os) FilePath
output_fn
(PhasePlus, FilePath) -> CompPipeline (PhasePlus, FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Phase -> PhasePlus
RealPhase Phase
StopLn, FilePath
output_fn)
runPhase (RealPhase Phase
other) FilePath
_input_fn DynFlags
_dflags =
FilePath -> CompPipeline (PhasePlus, FilePath)
forall a. FilePath -> a
panic (FilePath
"runPhase: don't know how to run phase " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Phase -> FilePath
forall a. Show a => a -> FilePath
show Phase
other)
maybeMergeForeign :: CompPipeline Phase
maybeMergeForeign :: CompPipeline Phase
maybeMergeForeign
= do
PipeState{[FilePath]
foreign_os :: [FilePath]
foreign_os :: PipeState -> [FilePath]
foreign_os} <- CompPipeline PipeState
getPipeState
if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
foreign_os then Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return Phase
StopLn else Phase -> CompPipeline Phase
forall (m :: * -> *) a. Monad m => a -> m a
return Phase
MergeForeign
getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
getLocation HscSource
src_flavour ModuleName
mod_name = do
DynFlags
dflags <- CompPipeline DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
PipeEnv{ src_basename :: PipeEnv -> FilePath
src_basename=FilePath
basename,
src_suffix :: PipeEnv -> FilePath
src_suffix=FilePath
suff } <- CompPipeline PipeEnv
getPipeEnv
PipeState { maybe_loc :: PipeState -> Maybe ModLocation
maybe_loc=Maybe ModLocation
maybe_loc} <- CompPipeline PipeState
getPipeState
case Maybe ModLocation
maybe_loc of
Just ModLocation
l -> ModLocation -> CompPipeline ModLocation
forall (m :: * -> *) a. Monad m => a -> m a
return (ModLocation -> CompPipeline ModLocation)
-> ModLocation -> CompPipeline ModLocation
forall a b. (a -> b) -> a -> b
$ ModLocation
l
{ ml_hs_file :: Maybe FilePath
ml_hs_file = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
basename FilePath -> FilePath -> FilePath
<.> FilePath
suff
, ml_hi_file :: FilePath
ml_hi_file = ModLocation -> FilePath
ml_hi_file ModLocation
l FilePath -> FilePath -> FilePath
-<.> DynFlags -> FilePath
hiSuf DynFlags
dflags
, ml_obj_file :: FilePath
ml_obj_file = ModLocation -> FilePath
ml_obj_file ModLocation
l FilePath -> FilePath -> FilePath
-<.> DynFlags -> FilePath
objectSuf DynFlags
dflags
}
Maybe ModLocation
_ -> do
ModLocation
location1 <- IO ModLocation -> CompPipeline ModLocation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModLocation -> CompPipeline ModLocation)
-> IO ModLocation -> CompPipeline ModLocation
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FilePath -> FilePath -> IO ModLocation
mkHomeModLocation2 DynFlags
dflags ModuleName
mod_name FilePath
basename FilePath
suff
let location2 :: ModLocation
location2
| HscSource
HsBootFile <- HscSource
src_flavour = ModLocation -> ModLocation
addBootSuffixLocnOut ModLocation
location1
| Bool
otherwise = ModLocation
location1
let ohi :: Maybe FilePath
ohi = DynFlags -> Maybe FilePath
outputHi DynFlags
dflags
location3 :: ModLocation
location3 | Just FilePath
fn <- Maybe FilePath
ohi = ModLocation
location2{ ml_hi_file :: FilePath
ml_hi_file = FilePath
fn }
| Bool
otherwise = ModLocation
location2
let expl_o_file :: Maybe FilePath
expl_o_file = DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
location4 :: ModLocation
location4 | Just FilePath
ofile <- Maybe FilePath
expl_o_file
, GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
= ModLocation
location3 { ml_obj_file :: FilePath
ml_obj_file = FilePath
ofile }
| Bool
otherwise = ModLocation
location3
ModLocation -> CompPipeline ModLocation
forall (m :: * -> *) a. Monad m => a -> m a
return ModLocation
location4
getHCFilePackages :: FilePath -> IO [UnitId]
getHCFilePackages :: FilePath -> IO [UnitId]
getHCFilePackages FilePath
filename =
IO Handle
-> (Handle -> IO ()) -> (Handle -> IO [UnitId]) -> IO [UnitId]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket (FilePath -> IOMode -> IO Handle
openFile FilePath
filename IOMode
ReadMode) Handle -> IO ()
hClose ((Handle -> IO [UnitId]) -> IO [UnitId])
-> (Handle -> IO [UnitId]) -> IO [UnitId]
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
FilePath
l <- Handle -> IO FilePath
hGetLine Handle
h
case FilePath
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':FilePath
rest ->
[UnitId] -> IO [UnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> UnitId) -> [FilePath] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> UnitId
stringToUnitId (FilePath -> [FilePath]
words FilePath
rest))
FilePath
_other ->
[UnitId] -> IO [UnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return []
linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary = Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary' Bool
False
linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary' Bool
staticLink DynFlags
dflags [FilePath]
o_files [UnitId]
dep_units = do
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
toolSettings' :: ToolSettings
toolSettings' = DynFlags -> ToolSettings
toolSettings DynFlags
dflags
verbFlags :: [FilePath]
verbFlags = DynFlags -> [FilePath]
getVerbFlags DynFlags
dflags
output_fn :: FilePath
output_fn = Bool -> DynFlags -> FilePath
exeFileName Bool
staticLink DynFlags
dflags
home_unit :: HomeUnit
home_unit = DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags
FilePath
full_output_fn <- if FilePath -> Bool
isAbsolute FilePath
output_fn
then FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
output_fn
else do FilePath
d <- IO FilePath
getCurrentDirectory
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
normalise (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
output_fn)
[FilePath]
pkg_lib_paths <- SDocContext
-> UnitState -> HomeUnit -> Set Way -> [UnitId] -> IO [FilePath]
getUnitLibraryPath
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
HomeUnit
home_unit
(DynFlags -> Set Way
ways DynFlags
dflags)
[UnitId]
dep_units
let pkg_lib_path_opts :: [FilePath]
pkg_lib_path_opts = (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> [FilePath]
get_pkg_lib_path_opts [FilePath]
pkg_lib_paths
get_pkg_lib_path_opts :: FilePath -> [FilePath]
get_pkg_lib_path_opts FilePath
l
| OS -> Bool
osElfTarget (Platform -> OS
platformOS Platform
platform) Bool -> Bool -> Bool
&&
DynFlags -> DynLibLoader
dynLibLoader DynFlags
dflags DynLibLoader -> DynLibLoader -> Bool
forall a. Eq a => a -> a -> Bool
== DynLibLoader
SystemDependent Bool -> Bool -> Bool
&&
Way
WayDyn Way -> Set Way -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> Set Way
ways DynFlags
dflags
= let libpath :: FilePath
libpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
then FilePath
"$ORIGIN" FilePath -> FilePath -> FilePath
</>
(FilePath
l FilePath -> FilePath -> FilePath
`makeRelativeTo` FilePath
full_output_fn)
else FilePath
l
rpath :: [FilePath]
rpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RPath DynFlags
dflags
then [FilePath
"-Xlinker", FilePath
"-rpath", FilePath
"-Xlinker", FilePath
libpath]
else []
rpathlink :: [FilePath]
rpathlink = if (Platform -> OS
platformOS Platform
platform) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSSolaris2
then []
else [FilePath
"-Xlinker", FilePath
"-rpath-link", FilePath
"-Xlinker", FilePath
l]
in [FilePath
"-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
rpathlink [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
rpath
| OS -> Bool
osMachOTarget (Platform -> OS
platformOS Platform
platform) Bool -> Bool -> Bool
&&
DynFlags -> DynLibLoader
dynLibLoader DynFlags
dflags DynLibLoader -> DynLibLoader -> Bool
forall a. Eq a => a -> a -> Bool
== DynLibLoader
SystemDependent Bool -> Bool -> Bool
&&
Way
WayDyn Way -> Set Way -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> Set Way
ways DynFlags
dflags Bool -> Bool -> Bool
&&
GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RPath DynFlags
dflags
= let libpath :: FilePath
libpath = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RelativeDynlibPaths DynFlags
dflags
then FilePath
"@loader_path" FilePath -> FilePath -> FilePath
</>
(FilePath
l FilePath -> FilePath -> FilePath
`makeRelativeTo` FilePath
full_output_fn)
else FilePath
l
in [FilePath
"-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"-Xlinker", FilePath
"-rpath", FilePath
"-Xlinker", FilePath
libpath]
| Bool
otherwise = [FilePath
"-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
l]
[FilePath]
pkg_lib_path_opts <-
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SingleLibFolder DynFlags
dflags
then do
[(FilePath, FilePath)]
libs <- DynFlags -> [UnitId] -> IO [(FilePath, FilePath)]
getLibs DynFlags
dflags [UnitId]
dep_units
FilePath
tmpDir <- DynFlags -> IO FilePath
newTempDir DynFlags
dflags
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ FilePath -> FilePath -> IO ()
copyFile FilePath
lib (FilePath
tmpDir FilePath -> FilePath -> FilePath
</> FilePath
basename)
| (FilePath
lib, FilePath
basename) <- [(FilePath, FilePath)]
libs]
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [ FilePath
"-L" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tmpDir ]
else [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath]
pkg_lib_path_opts
let
dead_strip :: [FilePath]
dead_strip
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags = []
| Bool
otherwise = if OS -> Bool
osSubsectionsViaSymbols (Platform -> OS
platformOS Platform
platform)
then [FilePath
"-Wl,-dead_strip"]
else []
let lib_paths :: [FilePath]
lib_paths = DynFlags -> [FilePath]
libraryPaths DynFlags
dflags
let lib_path_opts :: [FilePath]
lib_path_opts = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-L"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
lib_paths
FilePath
extraLinkObj <- DynFlags -> IO FilePath
mkExtraObjToLinkIntoBinary DynFlags
dflags
[FilePath]
noteLinkObjs <- DynFlags -> [UnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary DynFlags
dflags [UnitId]
dep_units
let
([FilePath]
pre_hs_libs, [FilePath]
post_hs_libs)
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags
= if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
then ([FilePath
"-Wl,-all_load"], [])
else ([FilePath
"-Wl,--whole-archive"], [FilePath
"-Wl,--no-whole-archive"])
| Bool
otherwise
= ([],[])
[FilePath]
pkg_link_opts <- do
([FilePath]
package_hs_libs, [FilePath]
extra_libs, [FilePath]
other_flags) <- DynFlags -> [UnitId] -> IO ([FilePath], [FilePath], [FilePath])
getUnitLinkOpts DynFlags
dflags [UnitId]
dep_units
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ if Bool
staticLink
then [FilePath]
package_hs_libs
else [FilePath]
other_flags [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
dead_strip
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pre_hs_libs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
package_hs_libs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
post_hs_libs
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_libs
[FilePath]
pkg_framework_opts <- DynFlags -> Platform -> [UnitId] -> IO [FilePath]
getUnitFrameworkOpts DynFlags
dflags Platform
platform [UnitId]
dep_units
let framework_opts :: [FilePath]
framework_opts = DynFlags -> Platform -> [FilePath]
getFrameworkOpts DynFlags
dflags Platform
platform
let extra_ld_inputs :: [Option]
extra_ld_inputs = DynFlags -> [Option]
ldInputs DynFlags
dflags
[FilePath]
rc_objs <- DynFlags -> FilePath -> IO [FilePath]
maybeCreateManifest DynFlags
dflags FilePath
output_fn
let link :: DynFlags -> [Option] -> IO ()
link DynFlags
dflags [Option]
args | Bool
staticLink = DynFlags -> [Option] -> IO ()
GHC.SysTools.runLibtool DynFlags
dflags [Option]
args
| Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
= DynFlags -> [Option] -> IO ()
GHC.SysTools.runLink DynFlags
dflags [Option]
args IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DynFlags -> [FilePath] -> FilePath -> IO ()
GHC.SysTools.runInjectRPaths DynFlags
dflags [FilePath]
pkg_lib_paths FilePath
output_fn
| Bool
otherwise
= DynFlags -> [Option] -> IO ()
GHC.SysTools.runLink DynFlags
dflags [Option]
args
DynFlags -> [Option] -> IO ()
link DynFlags
dflags (
(FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
verbFlags
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
GHC.SysTools.Option FilePath
"-o"
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn
]
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
libmLinkOpts
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option (
[]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [FilePath]
picCCOpts DynFlags
dflags
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
then [FilePath
"-Wl,--enable-auto-import"]
else [])
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if ToolSettings -> Bool
toolSettings_ldSupportsCompactUnwind ToolSettings
toolSettings' Bool -> Bool -> Bool
&&
Bool -> Bool
not Bool
staticLink Bool -> Bool -> Bool
&&
(Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin) Bool -> Bool -> Bool
&&
case Platform -> Arch
platformArch Platform
platform of
Arch
ArchX86 -> Bool
True
Arch
ArchX86_64 -> Bool
True
ArchARM {} -> Bool
True
Arch
ArchARM64 -> Bool
True
Arch
_ -> Bool
False
then [FilePath
"-Wl,-no_compact_unwind"]
else [])
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin Bool -> Bool -> Bool
&&
Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchX86 Bool -> Bool -> Bool
&&
Bool -> Bool
not Bool
staticLink
then [FilePath
"-Wl,-read_only_relocs,suppress"]
else [])
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if ToolSettings -> Bool
toolSettings_ldIsGnuLd ToolSettings
toolSettings' Bool -> Bool -> Bool
&&
Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WholeArchiveHsLibs DynFlags
dflags)
then [FilePath
"-Wl,--gc-sections"]
else [])
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
o_files
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
lib_path_opts)
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
extra_ld_inputs
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option (
[FilePath]
rc_objs
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
framework_opts
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_lib_path_opts
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ FilePath
extraLinkObjFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
noteLinkObjs
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_link_opts
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_framework_opts
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
then [ FilePath
"-Wl,-dead_strip_dylibs", FilePath
"-Wl,-headerpad,8000" ]
else [])
))
exeFileName :: Bool -> DynFlags -> FilePath
exeFileName :: Bool -> DynFlags -> FilePath
exeFileName Bool
staticLink DynFlags
dflags
| Just FilePath
s <- DynFlags -> Maybe FilePath
outputFile DynFlags
dflags =
case Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
OS
OSMinGW32 -> FilePath
s FilePath -> FilePath -> FilePath
<?.> FilePath
"exe"
OS
_ -> if Bool
staticLink
then FilePath
s FilePath -> FilePath -> FilePath
<?.> FilePath
"a"
else FilePath
s
| Bool
otherwise =
if Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
then FilePath
"main.exe"
else if Bool
staticLink
then FilePath
"liba.a"
else FilePath
"a.out"
where FilePath
s <?.> :: FilePath -> FilePath -> FilePath
<?.> FilePath
ext | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FilePath -> FilePath
takeExtension FilePath
s) = FilePath
s FilePath -> FilePath -> FilePath
<.> FilePath
ext
| Bool
otherwise = FilePath
s
maybeCreateManifest
:: DynFlags
-> FilePath
-> IO [FilePath]
maybeCreateManifest :: DynFlags -> FilePath -> IO [FilePath]
maybeCreateManifest DynFlags
dflags FilePath
exe_filename
| Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 Bool -> Bool -> Bool
&&
GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_GenManifest DynFlags
dflags
= do let manifest_filename :: FilePath
manifest_filename = FilePath
exe_filename FilePath -> FilePath -> FilePath
<.> FilePath
"manifest"
FilePath -> FilePath -> IO ()
writeFile FilePath
manifest_filename (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" <assemblyIdentity version=\"1.0.0.0\"\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" processorArchitecture=\"X86\"\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" name=\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
dropExtension FilePath
exe_filename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" type=\"win32\"/>\n\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" <security>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" <requestedPrivileges>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" </requestedPrivileges>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" </security>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
" </trustInfo>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
"</assembly>\n"
if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EmbedManifest DynFlags
dflags) then [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
FilePath
rc_filename <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"rc"
FilePath
rc_obj_filename <-
DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_GhcSession (DynFlags -> FilePath
objectSuf DynFlags
dflags)
FilePath -> FilePath -> IO ()
writeFile FilePath
rc_filename (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath
"1 24 MOVEABLE PURE " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
manifest_filename FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
DynFlags -> [Option] -> IO ()
runWindres DynFlags
dflags ([Option] -> IO ()) -> [Option] -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$
[FilePath
"--input="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
rc_filename,
FilePath
"--output="FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
rc_obj_filename,
FilePath
"--output-format=coff"]
FilePath -> IO ()
removeFile FilePath
manifest_filename
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
rc_obj_filename]
| Bool
otherwise = [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkDynLibCheck DynFlags
dflags [FilePath]
o_files [UnitId]
dep_units = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
haveRtsOptsFlags DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
LogAction
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevInfo SrcSpan
noSrcSpan
(SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
(FilePath -> SDoc
text FilePath
"Warning: -rtsopts and -with-rtsopts have no effect with -shared." SDoc -> SDoc -> SDoc
$$
FilePath -> SDoc
text FilePath
" Call hs_init_ghc() from your main() function to set these options.")
DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkDynLib DynFlags
dflags [FilePath]
o_files [UnitId]
dep_units
linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO ()
linkStaticLib :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkStaticLib DynFlags
dflags [FilePath]
o_files [UnitId]
dep_units = do
let extra_ld_inputs :: [FilePath]
extra_ld_inputs = [ FilePath
f | FileOption FilePath
_ FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
modules :: [FilePath]
modules = [FilePath]
o_files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
extra_ld_inputs
output_fn :: FilePath
output_fn = Bool -> DynFlags -> FilePath
exeFileName Bool
True DynFlags
dflags
home_unit :: HomeUnit
home_unit = DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags
FilePath
full_output_fn <- if FilePath -> Bool
isAbsolute FilePath
output_fn
then FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
output_fn
else do FilePath
d <- IO FilePath
getCurrentDirectory
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
normalise (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
output_fn)
Bool
output_exists <- FilePath -> IO Bool
doesFileExist FilePath
full_output_fn
(Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
output_exists) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
full_output_fn
[UnitInfo]
pkg_cfgs_init <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
HomeUnit
home_unit
[UnitId]
dep_units
let pkg_cfgs :: [UnitInfo]
pkg_cfgs
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LinkRts DynFlags
dflags
= [UnitInfo]
pkg_cfgs_init
| Bool
otherwise
= (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitId
rtsUnitId) (UnitId -> Bool) -> (UnitInfo -> UnitId) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId) [UnitInfo]
pkg_cfgs_init
[FilePath]
archives <- (UnitInfo -> IO [FilePath]) -> [UnitInfo] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (DynFlags -> UnitInfo -> IO [FilePath]
collectArchives DynFlags
dflags) [UnitInfo]
pkg_cfgs
Archive
ar <- (Archive -> Archive -> Archive) -> Archive -> [Archive] -> Archive
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Archive -> Archive -> Archive
forall a. Monoid a => a -> a -> a
mappend
(Archive -> [Archive] -> Archive)
-> IO Archive -> IO ([Archive] -> Archive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ArchiveEntry] -> Archive
Archive ([ArchiveEntry] -> Archive) -> IO [ArchiveEntry] -> IO Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO ArchiveEntry) -> [FilePath] -> IO [ArchiveEntry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO ArchiveEntry
loadObj [FilePath]
modules)
IO ([Archive] -> Archive) -> IO [Archive] -> IO Archive
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> IO Archive) -> [FilePath] -> IO [Archive]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO Archive
loadAr [FilePath]
archives
if ToolSettings -> Bool
toolSettings_ldIsGnuLd (DynFlags -> ToolSettings
toolSettings DynFlags
dflags)
then FilePath -> Archive -> IO ()
writeGNUAr FilePath
output_fn (Archive -> IO ()) -> Archive -> IO ()
forall a b. (a -> b) -> a -> b
$ (ArchiveEntry -> Bool) -> Archive -> Archive
afilter (Bool -> Bool
not (Bool -> Bool) -> (ArchiveEntry -> Bool) -> ArchiveEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveEntry -> Bool
isGNUSymdef) Archive
ar
else FilePath -> Archive -> IO ()
writeBSDAr FilePath
output_fn (Archive -> IO ()) -> Archive -> IO ()
forall a b. (a -> b) -> a -> b
$ (ArchiveEntry -> Bool) -> Archive -> Archive
afilter (Bool -> Bool
not (Bool -> Bool) -> (ArchiveEntry -> Bool) -> ArchiveEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveEntry -> Bool
isBSDSymdef) Archive
ar
DynFlags -> [Option] -> IO ()
runRanlib DynFlags
dflags [FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn]
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp DynFlags
dflags Bool
raw FilePath
input_fn FilePath
output_fn = do
let hscpp_opts :: [FilePath]
hscpp_opts = DynFlags -> [FilePath]
picPOpts DynFlags
dflags
let cmdline_include_paths :: IncludeSpecs
cmdline_include_paths = DynFlags -> IncludeSpecs
includePaths DynFlags
dflags
let home_unit :: HomeUnit
home_unit = DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags
[FilePath]
pkg_include_dirs <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitIncludePath
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
HomeUnit
home_unit
[]
let include_paths_global :: [FilePath]
include_paths_global = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ FilePath
x [FilePath]
xs -> (FilePath
"-I" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
(IncludeSpecs -> [FilePath]
includePathsGlobal IncludeSpecs
cmdline_include_paths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_include_dirs)
let include_paths_quote :: [FilePath]
include_paths_quote = (FilePath -> [FilePath] -> [FilePath])
-> [FilePath] -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ FilePath
x [FilePath]
xs -> (FilePath
"-iquote" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs) []
(IncludeSpecs -> [FilePath]
includePathsQuote IncludeSpecs
cmdline_include_paths)
let include_paths :: [FilePath]
include_paths = [FilePath]
include_paths_quote [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
include_paths_global
let verbFlags :: [FilePath]
verbFlags = DynFlags -> [FilePath]
getVerbFlags DynFlags
dflags
let cpp_prog :: [Option] -> IO ()
cpp_prog [Option]
args | Bool
raw = DynFlags -> [Option] -> IO ()
GHC.SysTools.runCpp DynFlags
dflags [Option]
args
| Bool
otherwise = Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()
GHC.SysTools.runCc Maybe ForeignSrcLang
forall a. Maybe a
Nothing DynFlags
dflags (FilePath -> Option
GHC.SysTools.Option FilePath
"-E" Option -> [Option] -> [Option]
forall a. a -> [a] -> [a]
: [Option]
args)
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
targetArch :: FilePath
targetArch = Arch -> FilePath
stringEncodeArch (Arch -> FilePath) -> Arch -> FilePath
forall a b. (a -> b) -> a -> b
$ Platform -> Arch
platformArch Platform
platform
targetOS :: FilePath
targetOS = OS -> FilePath
stringEncodeOS (OS -> FilePath) -> OS -> FilePath
forall a b. (a -> b) -> a -> b
$ Platform -> OS
platformOS Platform
platform
isWindows :: Bool
isWindows = Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
let target_defs :: [FilePath]
target_defs =
[ FilePath
"-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HOST_OS ++ "_BUILD_OS",
FilePath
"-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HOST_ARCH ++ "_BUILD_ARCH",
FilePath
"-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
targetOS FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_HOST_OS",
FilePath
"-D" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
targetArch FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_HOST_ARCH" ]
let io_manager_defs :: [FilePath]
io_manager_defs =
[ FilePath
"-D__IO_MANAGER_WINIO__=1" | Bool
isWindows ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"-D__IO_MANAGER_MIO__=1" ]
let sse_defs :: [FilePath]
sse_defs =
[ FilePath
"-D__SSE__" | Platform -> Bool
isSseEnabled Platform
platform ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"-D__SSE2__" | Platform -> Bool
isSse2Enabled Platform
platform ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"-D__SSE4_2__" | DynFlags -> Bool
isSse4_2Enabled DynFlags
dflags ]
let avx_defs :: [FilePath]
avx_defs =
[ FilePath
"-D__AVX__" | DynFlags -> Bool
isAvxEnabled DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"-D__AVX2__" | DynFlags -> Bool
isAvx2Enabled DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"-D__AVX512CD__" | DynFlags -> Bool
isAvx512cdEnabled DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"-D__AVX512ER__" | DynFlags -> Bool
isAvx512erEnabled DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"-D__AVX512F__" | DynFlags -> Bool
isAvx512fEnabled DynFlags
dflags ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
[ FilePath
"-D__AVX512PF__" | DynFlags -> Bool
isAvx512pfEnabled DynFlags
dflags ]
[FilePath]
backend_defs <- DynFlags -> IO [FilePath]
getBackendDefs DynFlags
dflags
let th_defs :: [FilePath]
th_defs = [ FilePath
"-D__GLASGOW_HASKELL_TH__" ]
FilePath
ghcVersionH <- DynFlags -> IO FilePath
getGhcVersionPathName DynFlags
dflags
let hsSourceCppOpts :: [FilePath]
hsSourceCppOpts = [ FilePath
"-include", FilePath
ghcVersionH ]
let state :: UnitState
state = DynFlags -> UnitState
unitState DynFlags
dflags
uids :: [Unit]
uids = UnitState -> [Unit]
explicitUnits UnitState
state
pkgs :: [UnitInfo]
pkgs = [Maybe UnitInfo] -> [UnitInfo]
forall a. [Maybe a] -> [a]
catMaybes ((Unit -> Maybe UnitInfo) -> [Unit] -> [Maybe UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
state) [Unit]
uids)
[Option]
mb_macro_include <-
if Bool -> Bool
not ([UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
pkgs) Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_VersionMacros DynFlags
dflags
then do FilePath
macro_stub <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"h"
FilePath -> FilePath -> IO ()
writeFile FilePath
macro_stub ([UnitInfo] -> FilePath
generatePackageVersionMacros [UnitInfo]
pkgs)
[Option] -> IO [Option]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"-include" FilePath
macro_stub]
else [Option] -> IO [Option]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Option] -> IO ()
cpp_prog ( (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
verbFlags
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
include_paths
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
hsSourceCppOpts
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
target_defs
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
backend_defs
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
th_defs
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
hscpp_opts
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
sse_defs
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
avx_defs
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
io_manager_defs
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
mb_macro_include
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
GHC.SysTools.Option FilePath
"-x"
, FilePath -> Option
GHC.SysTools.Option FilePath
"assembler-with-cpp"
, FilePath -> Option
GHC.SysTools.Option FilePath
input_fn
, FilePath -> Option
GHC.SysTools.Option FilePath
"-o"
, FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn
])
getBackendDefs :: DynFlags -> IO [String]
getBackendDefs :: DynFlags -> IO [FilePath]
getBackendDefs DynFlags
dflags | DynFlags -> Backend
backend DynFlags
dflags Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
== Backend
LLVM = do
Maybe LlvmVersion
llvmVer <- DynFlags -> IO (Maybe LlvmVersion)
figureLlvmVersion DynFlags
dflags
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ case (LlvmVersion -> [Int]) -> Maybe LlvmVersion -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LlvmVersion -> [Int]
llvmVersionList Maybe LlvmVersion
llvmVer of
Just [Int
m] -> [ FilePath
"-D__GLASGOW_HASKELL_LLVM__=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> FilePath
format (Int
m,Int
0) ]
Just (Int
m:Int
n:[Int]
_) -> [ FilePath
"-D__GLASGOW_HASKELL_LLVM__=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> FilePath
format (Int
m,Int
n) ]
Maybe [Int]
_ -> []
where
format :: (Int, Int) -> FilePath
format (Int
major, Int
minor)
| Int
minor Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
100 = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"getBackendDefs: Unsupported minor version"
| Bool
otherwise = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
major Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
minor :: Int)
getBackendDefs DynFlags
_ =
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
generatePackageVersionMacros :: [UnitInfo] -> String
generatePackageVersionMacros :: [UnitInfo] -> FilePath
generatePackageVersionMacros [UnitInfo]
pkgs = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ FilePath -> FilePath -> Version -> FilePath
generateMacros FilePath
"" FilePath
pkgname Version
version
| UnitInfo
pkg <- [UnitInfo]
pkgs
, let version :: Version
version = UnitInfo -> Version
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Version
unitPackageVersion UnitInfo
pkg
pkgname :: FilePath
pkgname = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar (UnitInfo -> FilePath
forall u. GenUnitInfo u -> FilePath
unitPackageNameString UnitInfo
pkg)
]
fixchar :: Char -> Char
fixchar :: Char -> Char
fixchar Char
'-' = Char
'_'
fixchar Char
c = Char
c
generateMacros :: String -> String -> Version -> String
generateMacros :: FilePath -> FilePath -> Version -> FilePath
generateMacros FilePath
prefix FilePath
name Version
version =
[FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[FilePath
"#define ", FilePath
prefix, FilePath
"VERSION_",FilePath
name,FilePath
" ",FilePath -> FilePath
forall a. Show a => a -> FilePath
show (Version -> FilePath
showVersion Version
version),FilePath
"\n"
,FilePath
"#define MIN_", FilePath
prefix, FilePath
"VERSION_",FilePath
name,FilePath
"(major1,major2,minor) (\\\n"
,FilePath
" (major1) < ",FilePath
major1,FilePath
" || \\\n"
,FilePath
" (major1) == ",FilePath
major1,FilePath
" && (major2) < ",FilePath
major2,FilePath
" || \\\n"
,FilePath
" (major1) == ",FilePath
major1,FilePath
" && (major2) == ",FilePath
major2,FilePath
" && (minor) <= ",FilePath
minor,FilePath
")"
,FilePath
"\n\n"
]
where
(FilePath
major1:FilePath
major2:FilePath
minor:[FilePath]
_) = (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FilePath
forall a. Show a => a -> FilePath
show (Version -> [Int]
versionBranch Version
version [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall a. a -> [a]
repeat Int
0)
joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
joinObjectFiles DynFlags
dflags [FilePath]
o_files FilePath
output_fn = do
let toolSettings' :: ToolSettings
toolSettings' = DynFlags -> ToolSettings
toolSettings DynFlags
dflags
ldIsGnuLd :: Bool
ldIsGnuLd = ToolSettings -> Bool
toolSettings_ldIsGnuLd ToolSettings
toolSettings'
osInfo :: OS
osInfo = Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
ld_r :: [Option] -> IO ()
ld_r [Option]
args = DynFlags -> [Option] -> IO ()
GHC.SysTools.runMergeObjects DynFlags
dflags (
[[Option]] -> [Option]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [FilePath -> Option
GHC.SysTools.Option FilePath
"--oformat", FilePath -> Option
GHC.SysTools.Option FilePath
"pe-bigobj-x86-64"]
| OS
OSMinGW32 OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
osInfo
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
]
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
GHC.SysTools.Option [FilePath]
ld_build_id
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [ FilePath -> Option
GHC.SysTools.Option FilePath
"-o",
FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
output_fn ]
[Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
args)
ld_build_id :: [FilePath]
ld_build_id | ToolSettings -> Bool
toolSettings_ldSupportsBuildId ToolSettings
toolSettings' = [FilePath
"--build-id=none"]
| Bool
otherwise = []
if Bool
ldIsGnuLd
then do
FilePath
script <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"ldscript"
FilePath
cwd <- IO FilePath
getCurrentDirectory
let o_files_abs :: [FilePath]
o_files_abs = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x -> FilePath
"\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath
cwd FilePath -> FilePath -> FilePath
</> FilePath
x) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\"") [FilePath]
o_files
FilePath -> FilePath -> IO ()
writeFile FilePath
script (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"INPUT(" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
o_files_abs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"
[Option] -> IO ()
ld_r [FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
script]
else if ToolSettings -> Bool
toolSettings_ldSupportsFilelist ToolSettings
toolSettings'
then do
FilePath
filelist <- DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule FilePath
"filelist"
FilePath -> FilePath -> IO ()
writeFile FilePath
filelist (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
o_files
[Option] -> IO ()
ld_r [FilePath -> Option
GHC.SysTools.Option FilePath
"-filelist",
FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"" FilePath
filelist]
else
[Option] -> IO ()
ld_r ((FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> Option
GHC.SysTools.FileOption FilePath
"") [FilePath]
o_files)
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags =
GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags Bool -> Bool -> Bool
&&
Backend
NoBackend Backend -> Backend -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Backend
backend DynFlags
dflags
sourceModified :: FilePath
-> UTCTime
-> IO Bool
sourceModified :: FilePath -> UTCTime -> IO Bool
sourceModified FilePath
dest_file UTCTime
src_timestamp = do
Bool
dest_file_exists <- FilePath -> IO Bool
doesFileExist FilePath
dest_file
if Bool -> Bool
not Bool
dest_file_exists
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do UTCTime
t2 <- FilePath -> IO UTCTime
getModificationUTCTime FilePath
dest_file
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
t2 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
src_timestamp)
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 :: DynFlags -> FilePath -> IO ()
touchObjectFile :: DynFlags -> FilePath -> IO ()
touchObjectFile DynFlags
dflags FilePath
path = do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
path
DynFlags -> FilePath -> FilePath -> IO ()
GHC.SysTools.touch DynFlags
dflags FilePath
"Touching object file" FilePath
path
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName DynFlags
dflags = do
[FilePath]
candidates <- case DynFlags -> Maybe FilePath
ghcVersionFile DynFlags
dflags of
Just FilePath
path -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
path]
Maybe FilePath
Nothing -> ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
"ghcversion.h")) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitIncludePath
(DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
(DynFlags -> UnitState
unitState DynFlags
dflags)
(DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags)
[UnitId
rtsUnitId])
[FilePath]
found <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist [FilePath]
candidates
case [FilePath]
found of
[] -> GhcException -> IO FilePath
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
InstallationError
(FilePath
"ghcversion.h missing; tried: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [FilePath]
candidates))
(FilePath
x:[FilePath]
_) -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
x