{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module GHC.Driver.Pipeline (
oneShot, compileFile,
preprocess,
compileOne, compileOne',
compileForeign, compileEmptyStub,
link, linkingNeeded, checkLinkInfo,
PipeEnv(..), mkPipeEnv, phaseOutputFilenameNew,
TPhase(..), runPhase,
hscPostBackendPhase,
TPipelineClass, MonadUse(..),
preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline,
hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline,
llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,
runPipeline
) where
import GHC.Prelude
import GHC.Platform
import GHC.Utils.Monad ( MonadIO(liftIO), mapMaybeM )
import GHC.Driver.Main
import GHC.Driver.Env hiding ( Hsc )
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Pipeline.Monad
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Phases
import GHC.Driver.Pipeline.Execute
import GHC.Driver.Pipeline.Phases
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Driver.Hooks
import GHC.Platform.Ways
import GHC.SysTools
import GHC.Utils.TmpFs
import GHC.Linker.ExtraObj
import GHC.Linker.Static
import GHC.Linker.Static.Utils
import GHC.Linker.Types
import GHC.Utils.Outputable
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Exception as Exception
import GHC.Utils.Logger
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString ( mkFastString )
import GHC.Data.StringBuffer ( hPutStringBuffer )
import GHC.Data.Maybe ( expectJust )
import GHC.Iface.Make ( mkFullIface )
import GHC.Runtime.Loader ( initializePlugins )
import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) )
import GHC.Types.Error ( singleMessage, getMessages )
import GHC.Types.Target
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
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.Maybe
import Data.Either ( partitionEithers )
import qualified Data.Set as Set
import Data.Time ( getCurrentTime )
import GHC.Iface.Recomp
type P m = TPipelineClass TPhase m
preprocess :: HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either DriverMessages (DynFlags, FilePath))
preprocess :: HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either DriverMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
input_fn Maybe InputFileBuffer
mb_input_buf Maybe Phase
mb_phase =
(SourceError -> IO (Either DriverMessages (DynFlags, FilePath)))
-> IO (Either DriverMessages (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath))
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
err -> Either DriverMessages (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DriverMessages (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath)))
-> Either DriverMessages (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$ DriverMessages -> Either DriverMessages (DynFlags, FilePath)
forall a b. a -> Either a b
Left (DriverMessages -> Either DriverMessages (DynFlags, FilePath))
-> DriverMessages -> Either DriverMessages (DynFlags, FilePath)
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> DriverMessages
to_driver_messages (Messages GhcMessage -> DriverMessages)
-> Messages GhcMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SourceError -> Messages GhcMessage
srcErrorMessages SourceError
err) (IO (Either DriverMessages (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath)))
-> IO (Either DriverMessages (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$
(GhcException -> IO (Either DriverMessages (DynFlags, FilePath)))
-> IO (Either DriverMessages (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
MC.handle GhcException -> IO (Either DriverMessages (DynFlags, FilePath))
handler (IO (Either DriverMessages (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath)))
-> IO (Either DriverMessages (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$
((DynFlags, FilePath)
-> Either DriverMessages (DynFlags, FilePath))
-> IO (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags, FilePath) -> Either DriverMessages (DynFlags, FilePath)
forall a b. b -> Either a b
Right (IO (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath)))
-> IO (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$ do
Bool -> SDoc -> IO ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Maybe Phase -> Bool
forall a. Maybe a -> Bool
isJust Maybe Phase
mb_phase Bool -> Bool -> Bool
|| FilePath -> Bool
isHaskellSrcFilename FilePath
input_fn) (FilePath -> SDoc
text FilePath
input_fn)
FilePath
input_fn_final <- IO FilePath
mkInputFn
let preprocess_pipeline :: HookedUse (DynFlags, FilePath)
preprocess_pipeline = PipeEnv -> HscEnv -> FilePath -> HookedUse (DynFlags, FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
preprocessPipeline PipeEnv
pipe_env (PipeEnv -> HscEnv -> HscEnv
setDumpPrefix PipeEnv
pipe_env HscEnv
hsc_env) FilePath
input_fn_final
Hooks -> HookedUse (DynFlags, FilePath) -> IO (DynFlags, FilePath)
forall a. Hooks -> HookedUse a -> IO a
runPipeline (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) HookedUse (DynFlags, FilePath)
preprocess_pipeline
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 DriverMessages (DynFlags, FilePath))
handler (ProgramError FilePath
msg) =
Either DriverMessages (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DriverMessages (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath)))
-> Either DriverMessages (DynFlags, FilePath)
-> IO (Either DriverMessages (DynFlags, FilePath))
forall a b. (a -> b) -> a -> b
$ DriverMessages -> Either DriverMessages (DynFlags, FilePath)
forall a b. a -> Either a b
Left (DriverMessages -> Either DriverMessages (DynFlags, FilePath))
-> DriverMessages -> Either DriverMessages (DynFlags, FilePath)
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$
SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
srcspan (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$
DiagnosticMessage -> DriverMessage
forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage (DiagnosticMessage -> DriverMessage)
-> DiagnosticMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
msg
handler GhcException
ex = GhcException -> IO (Either DriverMessages (DynFlags, FilePath))
forall a. GhcException -> IO a
throwGhcExceptionIO GhcException
ex
to_driver_messages :: Messages GhcMessage -> Messages DriverMessage
to_driver_messages :: Messages GhcMessage -> DriverMessages
to_driver_messages Messages GhcMessage
msgs = case (GhcMessage -> Maybe DriverMessage)
-> Messages GhcMessage -> Maybe DriverMessages
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Messages a -> f (Messages b)
traverse GhcMessage -> Maybe DriverMessage
to_driver_message Messages GhcMessage
msgs of
Maybe DriverMessages
Nothing -> FilePath -> SDoc -> DriverMessages
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"non-driver message in preprocess"
([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope GhcMessage) -> [SDoc]
forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages GhcMessage
msgs))
Just DriverMessages
msgs' -> DriverMessages
msgs'
to_driver_message :: GhcMessage -> Maybe DriverMessage
to_driver_message = \case
GhcDriverMessage DriverMessage
msg
-> DriverMessage -> Maybe DriverMessage
forall a. a -> Maybe a
Just DriverMessage
msg
GhcPsMessage (PsHeaderMessage PsHeaderMessage
msg)
-> DriverMessage -> Maybe DriverMessage
forall a. a -> Maybe a
Just (PsMessage -> DriverMessage
DriverPsHeaderMessage (PsHeaderMessage -> PsMessage
PsHeaderMessage PsHeaderMessage
msg))
GhcMessage
_ -> Maybe DriverMessage
forall a. Maybe a
Nothing
pipe_env :: PipeEnv
pipe_env = StopPhase -> FilePath -> Maybe Phase -> PipelineOutput -> PipeEnv
mkPipeEnv StopPhase
StopPreprocess FilePath
input_fn Maybe Phase
mb_phase (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_GhcSession)
mkInputFn :: IO FilePath
mkInputFn =
case Maybe InputFileBuffer
mb_input_buf of
Just InputFileBuffer
input_buf -> do
FilePath
fn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
(DynFlags -> TempDir
tmpDir (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
TempFileLifetime
TFL_CurrentModule
(FilePath
"buf_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PipeEnv -> FilePath
src_suffix PipeEnv
pipe_env)
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fn
Maybe InputFileBuffer
Nothing -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
input_fn
compileOne :: HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> IO HomeModInfo
compileOne :: HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> IO HomeModInfo
compileOne = Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> IO HomeModInfo
compileOne' (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
batchMsg)
compileOne' :: Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> IO HomeModInfo
compileOne' :: Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> IO HomeModInfo
compileOne' Maybe Messager
mHscMessage
HscEnv
hsc_env0 ModSummary
summary Int
mod_index Int
nmods Maybe ModIface
mb_old_iface Maybe Linkable
mb_old_linkable
= do
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (FilePath -> SDoc
text FilePath
"compile: input file" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
input_fnpp)
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
$
TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs 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
$
TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs 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]
HscEnv
plugin_hsc_env <- HscEnv -> IO HscEnv
initializePlugins HscEnv
hsc_env
let pipe_env :: PipeEnv
pipe_env = StopPhase -> FilePath -> Maybe Phase -> PipelineOutput -> PipeEnv
mkPipeEnv StopPhase
NoStop FilePath
input_fn Maybe Phase
forall a. Maybe a
Nothing PipelineOutput
pipelineOutput
HscRecompStatus
status <- Maybe Messager
-> HscEnv
-> ModSummary
-> Maybe ModIface
-> Maybe Linkable
-> (Int, Int)
-> IO HscRecompStatus
hscRecompStatus Maybe Messager
mHscMessage HscEnv
plugin_hsc_env ModSummary
upd_summary
Maybe ModIface
mb_old_iface Maybe Linkable
mb_old_linkable (Int
mod_index, Int
nmods)
let pipeline :: HookedUse (ModIface, Maybe Linkable)
pipeline = PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> HookedUse (ModIface, Maybe Linkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> m (ModIface, Maybe Linkable)
hscPipeline PipeEnv
pipe_env (PipeEnv -> HscEnv -> HscEnv
setDumpPrefix PipeEnv
pipe_env HscEnv
plugin_hsc_env, ModSummary
upd_summary, HscRecompStatus
status)
(ModIface
iface, Maybe Linkable
linkable) <- Hooks
-> HookedUse (ModIface, Maybe Linkable)
-> IO (ModIface, Maybe Linkable)
forall a. Hooks -> HookedUse a -> IO a
runPipeline (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) HookedUse (ModIface, Maybe Linkable)
pipeline
ModDetails
details <- HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails HscEnv
plugin_hsc_env ModSummary
upd_summary ModIface
iface
HomeModInfo -> IO HomeModInfo
forall a. a -> IO a
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 Maybe Linkable
linkable
where lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts 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
pipelineOutput :: PipelineOutput
pipelineOutput = case Backend
bcknd of
Backend
Interpreter -> PipelineOutput
NoOutputFile
Backend
NoBackend -> PipelineOutput
NoOutputFile
Backend
_ -> PipelineOutput
Persistent
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env0
tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env0
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
lcl_dflags
loadAsByteCode :: Bool
loadAsByteCode
| Just Target { targetAllowObjCode :: Target -> Bool
targetAllowObjCode = Bool
obj } <- ModSummary -> [Target] -> Maybe Target
findTarget ModSummary
summary (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env0)
, Bool -> Bool
not Bool
obj
= Bool
True
| Bool
otherwise = Bool
False
(Backend
bcknd, DynFlags
dflags3)
| Bool
loadAsByteCode
= (Backend
Interpreter, DynFlags -> GeneralFlag -> DynFlags
gopt_set (DynFlags
lcl_dflags { backend :: Backend
backend = Backend
Interpreter }) GeneralFlag
Opt_ForceRecomp)
| Bool
otherwise
= (DynFlags -> Backend
backend DynFlags
dflags, DynFlags
lcl_dflags)
dflags :: DynFlags
dflags = DynFlags
dflags3 { includePaths :: IncludeSpecs
includePaths = DynFlags -> IncludeSpecs -> IncludeSpecs
offsetIncludePaths DynFlags
dflags3 (IncludeSpecs -> IncludeSpecs) -> IncludeSpecs -> IncludeSpecs
forall a b. (a -> b) -> a -> b
$ IncludeSpecs -> [FilePath] -> IncludeSpecs
addImplicitQuoteInclude IncludeSpecs
old_paths [FilePath
current_dir] }
upd_summary :: ModSummary
upd_summary = ModSummary
summary { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags }
hsc_env :: HscEnv
hsc_env = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
hsc_env0
link :: GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link :: GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link GhcLink
ghcLink Logger
logger TmpFs
tmpfs Hooks
hooks DynFlags
dflags UnitEnv
unit_env Bool
batch_attempt_linking Maybe (RecompileRequired -> IO ())
mHscMessage HomePackageTable
hpt =
case Hooks
-> Maybe
(GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
linkHook Hooks
hooks of
Maybe
(GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
Nothing -> case GhcLink
ghcLink of
GhcLink
NoLink -> SuccessFlag -> IO SuccessFlag
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
GhcLink
LinkBinary -> IO SuccessFlag
normal_link
GhcLink
LinkStaticLib -> IO SuccessFlag
normal_link
GhcLink
LinkDynLib -> IO SuccessFlag
normal_link
GhcLink
LinkMergedObj -> IO SuccessFlag
normal_link
GhcLink
LinkInMemory
| PlatformMisc -> Bool
platformMisc_ghcWithInterpreter (PlatformMisc -> Bool) -> PlatformMisc -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> PlatformMisc
platformMisc DynFlags
dflags
->
SuccessFlag -> IO SuccessFlag
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
| Bool
otherwise
-> GhcLink -> IO SuccessFlag
forall a. GhcLink -> a
panicBadLink GhcLink
LinkInMemory
Just GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
h -> GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
h GhcLink
ghcLink DynFlags
dflags Bool
batch_attempt_linking HomePackageTable
hpt
where
normal_link :: IO SuccessFlag
normal_link = Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link' Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env Bool
batch_attempt_linking Maybe (RecompileRequired -> IO ())
mHscMessage HomePackageTable
hpt
panicBadLink :: GhcLink -> a
panicBadLink :: forall a. 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' :: Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link' :: Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link' Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env Bool
batch_attempt_linking Maybe (RecompileRequired -> IO ())
mHscMessager 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 = Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList
(Set UnitId -> [UnitId]) -> Set UnitId -> [UnitId]
forall a b. (a -> b) -> a -> b
$ [Set UnitId] -> Set UnitId
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
([Set UnitId] -> Set UnitId) -> [Set UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ (HomeModInfo -> Set UnitId) -> [HomeModInfo] -> [Set UnitId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dependencies -> Set UnitId
dep_direct_pkgs (Dependencies -> Set UnitId)
-> (HomeModInfo -> Dependencies) -> HomeModInfo -> Set UnitId
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] -> [Set UnitId]) -> [HomeModInfo] -> [Set UnitId]
forall a b. (a -> b) -> a -> b
$ [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
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger 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 Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (FilePath -> SDoc
text FilePath
"link(batch): linking omitted (-c flag given).")
SuccessFlag -> IO SuccessFlag
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
else do
let getOfiles :: Linkable -> [FilePath]
getOfiles LM{ [Unlinked]
linkableUnlinked :: [Unlinked]
linkableUnlinked :: Linkable -> [Unlinked]
linkableUnlinked } = (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]
linkableUnlinked)
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
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
exe_file :: FilePath
exe_file = Platform -> Bool -> Maybe FilePath -> FilePath
exeFileName Platform
platform Bool
staticLink (DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags)
RecompileRequired
linking_needed <- Logger
-> DynFlags
-> UnitEnv
-> Bool
-> [Linkable]
-> [UnitId]
-> IO RecompileRequired
linkingNeeded Logger
logger DynFlags
dflags UnitEnv
unit_env Bool
staticLink [Linkable]
linkables [UnitId]
pkg_deps
Maybe (RecompileRequired -> IO ())
-> ((RecompileRequired -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (RecompileRequired -> IO ())
mHscMessager (((RecompileRequired -> IO ()) -> IO ()) -> IO ())
-> ((RecompileRequired -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RecompileRequired -> IO ()
hscMessage -> RecompileRequired -> IO ()
hscMessage RecompileRequired
linking_needed
if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp DynFlags
dflags) Bool -> Bool -> Bool
&& (RecompileRequired
linking_needed RecompileRequired -> RecompileRequired -> Bool
forall a. Eq a => a -> a -> Bool
== RecompileRequired
UpToDate)
then do Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
else do
let link :: DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
link = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
GhcLink
LinkBinary -> Logger
-> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkBinary Logger
logger TmpFs
tmpfs
GhcLink
LinkStaticLib -> Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkStaticLib Logger
logger
GhcLink
LinkDynLib -> Logger
-> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkDynLibCheck Logger
logger TmpFs
tmpfs
GhcLink
other -> GhcLink -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
forall a. GhcLink -> a
panicBadLink GhcLink
other
DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
link DynFlags
dflags UnitEnv
unit_env [FilePath]
obj_files [UnitId]
pkg_deps
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (FilePath -> SDoc
text FilePath
"link: done")
SuccessFlag -> IO SuccessFlag
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
| Bool
otherwise
= do Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired
linkingNeeded :: Logger
-> DynFlags
-> UnitEnv
-> Bool
-> [Linkable]
-> [UnitId]
-> IO RecompileRequired
linkingNeeded Logger
logger DynFlags
dflags UnitEnv
unit_env Bool
staticLink [Linkable]
linkables [UnitId]
pkg_deps = do
let platform :: Platform
platform = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
unit_state :: UnitState
unit_state = (() :: Constraint) => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env
exe_file :: FilePath
exe_file = Platform -> Bool -> Maybe FilePath -> FilePath
exeFileName Platform
platform Bool
staticLink (DynFlags -> Maybe FilePath
outputFile_ 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
_ -> RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
MustCompile
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. [a] -> 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 RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
ObjectsChanged
else do
let pkg_hslibs :: [([FilePath], FilePath)]
pkg_hslibs = [ (Ways -> [UnitInfo] -> [FilePath]
collectLibraryDirs (DynFlags -> Ways
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 <- GhcNameVersion -> Ways -> UnitInfo -> [FilePath]
unitHsLibs (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Ways
ways 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([FilePath] -> FilePath -> IO (Maybe FilePath))
-> ([FilePath], FilePath) -> IO (Maybe FilePath)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Platform -> Ways -> [FilePath] -> FilePath -> IO (Maybe FilePath)
findHSLib Platform
platform (DynFlags -> Ways
ways 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 RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
LibraryChanged 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. [a] -> 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 RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
LibraryChanged
else do
Bool
res <- Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool
checkLinkInfo Logger
logger DynFlags
dflags UnitEnv
unit_env [UnitId]
pkg_deps FilePath
exe_file
if Bool
res
then RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecompileRequired -> IO RecompileRequired)
-> RecompileRequired -> IO RecompileRequired
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
FlagsChanged
else RecompileRequired -> IO RecompileRequired
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecompileRequired
UpToDate
findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)
findHSLib :: Platform -> Ways -> [FilePath] -> FilePath -> IO (Maybe FilePath)
findHSLib Platform
platform Ways
ws [FilePath]
dirs FilePath
lib = do
let batch_lib_file :: FilePath
batch_lib_file = if Ways
ws Ways -> Way -> Bool
`hasNotWay` Way
WayDyn
then FilePath
"lib" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
lib FilePath -> FilePath -> FilePath
<.> FilePath
"a"
else Platform -> FilePath -> FilePath
platformSOName Platform
platform 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
x)
oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()
oneShot :: HscEnv -> StopPhase -> [(FilePath, Maybe Phase)] -> IO ()
oneShot HscEnv
hsc_env StopPhase
stop_phase [(FilePath, Maybe Phase)]
srcs = do
[FilePath]
o_files <- ((FilePath, Maybe Phase) -> IO (Maybe FilePath))
-> [(FilePath, Maybe Phase)] -> IO [FilePath]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (HscEnv
-> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
compileFile HscEnv
hsc_env StopPhase
stop_phase) [(FilePath, Maybe Phase)]
srcs
case StopPhase
stop_phase of
StopPhase
StopPreprocess -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
StopPhase
StopC -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
StopPhase
StopAs -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
StopPhase
NoStop -> HscEnv -> [FilePath] -> IO ()
doLink HscEnv
hsc_env [FilePath]
o_files
compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
compileFile :: HscEnv
-> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
compileFile HscEnv
hsc_env StopPhase
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
notStopPreprocess :: Bool
notStopPreprocess | StopPhase
StopPreprocess <- StopPhase
stop_phase = Bool
False
| StopPhase
_ <- StopPhase
stop_phase = Bool
True
output :: PipelineOutput
output
| Backend
NoBackend <- DynFlags -> Backend
backend DynFlags
dflags, Bool
notStopPreprocess = PipelineOutput
NoOutputFile
| StopPhase
NoStop <- StopPhase
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
pipe_env :: PipeEnv
pipe_env = StopPhase -> FilePath -> Maybe Phase -> PipelineOutput -> PipeEnv
mkPipeEnv StopPhase
stop_phase FilePath
src Maybe Phase
mb_phase PipelineOutput
output
pipeline :: HookedUse (Maybe FilePath)
pipeline = PipeEnv
-> HscEnv -> FilePath -> Maybe Phase -> HookedUse (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)
pipelineStart PipeEnv
pipe_env (PipeEnv -> HscEnv -> HscEnv
setDumpPrefix PipeEnv
pipe_env HscEnv
hsc_env) FilePath
src Maybe Phase
mb_phase
Hooks -> HookedUse (Maybe FilePath) -> IO (Maybe FilePath)
forall a. Hooks -> HookedUse a -> IO a
runPipeline (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) HookedUse (Maybe FilePath)
pipeline
doLink :: HscEnv -> [FilePath] -> IO ()
doLink :: HscEnv -> [FilePath] -> IO ()
doLink HscEnv
hsc_env [FilePath]
o_files =
let
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
in case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
GhcLink
NoLink -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
GhcLink
LinkBinary -> Logger
-> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkBinary Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [FilePath]
o_files []
GhcLink
LinkStaticLib -> Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkStaticLib Logger
logger DynFlags
dflags UnitEnv
unit_env [FilePath]
o_files []
GhcLink
LinkDynLib -> Logger
-> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkDynLibCheck Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [FilePath]
o_files []
GhcLink
LinkMergedObj
| Just FilePath
out <- DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
, let objs :: [FilePath]
objs = [ FilePath
f | FileOption FilePath
_ FilePath
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags ]
-> HscEnv -> [FilePath] -> FilePath -> IO ()
joinObjectFiles HscEnv
hsc_env ([FilePath]
o_files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
objs) FilePath
out
| Bool
otherwise -> FilePath -> IO ()
forall a. FilePath -> a
panic FilePath
"Output path must be specified for LinkMergedObj"
GhcLink
other -> GhcLink -> IO ()
forall a. GhcLink -> a
panicBadLink GhcLink
other
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign HscEnv
_ ForeignSrcLang
RawObject FilePath
object_file = FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
object_file
compileForeign HscEnv
hsc_env ForeignSrcLang
lang FilePath
stub_c = do
let pipeline :: PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> HookedUse (Maybe FilePath)
pipeline = case ForeignSrcLang
lang of
ForeignSrcLang
LangC -> Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> HookedUse (Maybe FilePath)
forall (m :: * -> *).
P m =>
Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
viaCPipeline Phase
Cc
ForeignSrcLang
LangCxx -> Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> HookedUse (Maybe FilePath)
forall (m :: * -> *).
P m =>
Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
viaCPipeline Phase
Ccxx
ForeignSrcLang
LangObjc -> Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> HookedUse (Maybe FilePath)
forall (m :: * -> *).
P m =>
Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
viaCPipeline Phase
Cobjc
ForeignSrcLang
LangObjcxx -> Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> HookedUse (Maybe FilePath)
forall (m :: * -> *).
P m =>
Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
viaCPipeline Phase
Cobjcxx
ForeignSrcLang
LangAsm -> \PipeEnv
pe HscEnv
hsc_env Maybe ModLocation
ml FilePath
fp -> Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> HookedUse (Maybe FilePath)
forall (m :: * -> *).
P m =>
Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
asPipeline Bool
True PipeEnv
pe HscEnv
hsc_env Maybe ModLocation
ml FilePath
fp
#if __GLASGOW_HASKELL__ < 811
RawObject -> panic "compileForeign: should be unreachable"
#endif
pipe_env :: PipeEnv
pipe_env = StopPhase -> FilePath -> Maybe Phase -> PipelineOutput -> PipeEnv
mkPipeEnv StopPhase
NoStop FilePath
stub_c Maybe Phase
forall a. Maybe a
Nothing (TempFileLifetime -> PipelineOutput
Temporary TempFileLifetime
TFL_GhcSession)
Maybe FilePath
res <- Hooks -> HookedUse (Maybe FilePath) -> IO (Maybe FilePath)
forall a. Hooks -> HookedUse a -> IO a
runPipeline (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) (PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> HookedUse (Maybe FilePath)
pipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
forall a. Maybe a
Nothing FilePath
stub_c)
case Maybe FilePath
res of
Maybe FilePath
Nothing -> FilePath -> SDoc -> IO FilePath
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"compileForeign" (FilePath -> SDoc
forall a. Outputable a => a -> SDoc
ppr FilePath
stub_c)
Just FilePath
fp -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fp
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
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
FilePath
empty_stub <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir 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))
let pipe_env :: PipeEnv
pipe_env = (StopPhase -> FilePath -> Maybe Phase -> PipelineOutput -> PipeEnv
mkPipeEnv StopPhase
NoStop FilePath
empty_stub Maybe Phase
forall a. Maybe a
Nothing PipelineOutput
Persistent) { src_basename :: FilePath
src_basename = FilePath
basename}
pipeline :: HookedUse (Maybe FilePath)
pipeline = Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> HookedUse (Maybe FilePath)
forall (m :: * -> *).
P m =>
Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
viaCPipeline Phase
HCc PipeEnv
pipe_env HscEnv
hsc_env (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location) FilePath
empty_stub
Maybe FilePath
_ <- Hooks -> HookedUse (Maybe FilePath) -> IO (Maybe FilePath)
forall a. Hooks -> HookedUse a -> IO a
runPipeline (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) HookedUse (Maybe FilePath)
pipeline
() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkPipeEnv :: StopPhase
-> FilePath
-> Maybe Phase
-> PipelineOutput
-> PipeEnv
mkPipeEnv :: StopPhase -> FilePath -> Maybe Phase -> PipelineOutput -> PipeEnv
mkPipeEnv StopPhase
stop_phase FilePath
input_fn Maybe Phase
start_phase PipelineOutput
output =
let (FilePath
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
env :: PipeEnv
env = PipeEnv{ StopPhase
stop_phase :: StopPhase
stop_phase :: StopPhase
stop_phase,
src_filename :: FilePath
src_filename = FilePath
input_fn,
src_basename :: FilePath
src_basename = FilePath
basename,
src_suffix :: FilePath
src_suffix = FilePath
suffix',
start_phase :: Phase
start_phase = Phase -> Maybe Phase -> Phase
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Phase
startPhase FilePath
suffix') Maybe Phase
start_phase,
output_spec :: PipelineOutput
output_spec = PipelineOutput
output }
in PipeEnv
env
setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv
setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv
setDumpPrefix PipeEnv
pipe_env HscEnv
hsc_env =
(DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags (\DynFlags
dflags -> DynFlags
dflags { dumpPrefix :: FilePath
dumpPrefix = PipeEnv -> FilePath
src_basename PipeEnv
pipe_env FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"."}) HscEnv
hsc_env
phaseIfFlag :: Monad m
=> HscEnv
-> (DynFlags -> Bool)
-> a
-> m a
-> m a
phaseIfFlag :: forall (m :: * -> *) a.
Monad m =>
HscEnv -> (DynFlags -> Bool) -> a -> m a -> m a
phaseIfFlag HscEnv
hsc_env DynFlags -> Bool
flag a
def m a
action =
if DynFlags -> Bool
flag (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
then m a
action
else a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
def
phaseIfAfter :: P m => Platform -> Phase -> Phase -> a -> m a -> m a
phaseIfAfter :: forall (m :: * -> *) a.
P m =>
Platform -> Phase -> Phase -> a -> m a -> m a
phaseIfAfter Platform
platform Phase
start_phase Phase
cur_phase a
def m a
action =
if Phase
start_phase Phase -> Phase -> Bool
`eqPhase` Phase
cur_phase
Bool -> Bool -> Bool
|| Platform -> Phase -> Phase -> Bool
happensBefore Platform
platform Phase
start_phase Phase
cur_phase
then m a
action
else a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
def
preprocessPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
preprocessPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
preprocessPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn = do
FilePath
unlit_fn <-
Phase -> FilePath -> m FilePath -> m FilePath
forall (p :: * -> *) a. P p => Phase -> a -> p a -> p a
runAfter (HscSource -> Phase
Unlit HscSource
HsSrcFile) FilePath
input_fn (m FilePath -> m FilePath) -> m FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ do
TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_Unlit PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn)
(DynFlags
dflags1, Messages PsMessage
p_warns1, [Warn]
warns1) <- TPhase (DynFlags, Messages PsMessage, [Warn])
-> m (DynFlags, Messages PsMessage, [Warn])
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, [Warn])
T_FileArgs HscEnv
hsc_env FilePath
unlit_fn)
let hsc_env1 :: HscEnv
hsc_env1 = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags1 HscEnv
hsc_env
(FilePath
cpp_fn, HscEnv
hsc_env2)
<- HscEnv
-> Phase
-> (DynFlags -> Bool)
-> (FilePath, HscEnv)
-> m (FilePath, HscEnv)
-> m (FilePath, HscEnv)
forall (p :: * -> *) a.
P p =>
HscEnv -> Phase -> (DynFlags -> Bool) -> a -> p a -> p a
runAfterFlag HscEnv
hsc_env1 (HscSource -> Phase
Cpp HscSource
HsSrcFile) (Extension -> DynFlags -> Bool
xopt Extension
LangExt.Cpp) (FilePath
unlit_fn, HscEnv
hsc_env1) (m (FilePath, HscEnv) -> m (FilePath, HscEnv))
-> m (FilePath, HscEnv) -> m (FilePath, HscEnv)
forall a b. (a -> b) -> a -> b
$ do
FilePath
cpp_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_Cpp PipeEnv
pipe_env HscEnv
hsc_env1 FilePath
unlit_fn)
(DynFlags
dflags2, Messages PsMessage
_, [Warn]
_) <- TPhase (DynFlags, Messages PsMessage, [Warn])
-> m (DynFlags, Messages PsMessage, [Warn])
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, [Warn])
T_FileArgs HscEnv
hsc_env1 FilePath
cpp_fn)
let hsc_env2 :: HscEnv
hsc_env2 = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags2 HscEnv
hsc_env1
(FilePath, HscEnv) -> m (FilePath, HscEnv)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
cpp_fn, HscEnv
hsc_env2)
FilePath
pp_fn <- HscEnv
-> Phase
-> (DynFlags -> Bool)
-> FilePath
-> m FilePath
-> m FilePath
forall (p :: * -> *) a.
P p =>
HscEnv -> Phase -> (DynFlags -> Bool) -> a -> p a -> p a
runAfterFlag HscEnv
hsc_env2 (HscSource -> Phase
HsPp HscSource
HsSrcFile) (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp) FilePath
cpp_fn (m FilePath -> m FilePath) -> m FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$
TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath
T_HsPp PipeEnv
pipe_env HscEnv
hsc_env2 FilePath
input_fn FilePath
cpp_fn)
(DynFlags
dflags3, Messages PsMessage
p_warns3, [Warn]
warns3)
<- if FilePath
pp_fn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
unlit_fn
then (DynFlags, Messages PsMessage, [Warn])
-> m (DynFlags, Messages PsMessage, [Warn])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags1, Messages PsMessage
p_warns1, [Warn]
warns1)
else do
TPhase (DynFlags, Messages PsMessage, [Warn])
-> m (DynFlags, Messages PsMessage, [Warn])
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, [Warn])
T_FileArgs HscEnv
hsc_env FilePath
pp_fn)
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags3) (PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
p_warns3))
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags3) [Warn]
warns3)
(DynFlags, FilePath) -> m (DynFlags, FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
dflags3, FilePath
pp_fn)
where platform :: Platform
platform = DynFlags -> Platform
targetPlatform (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
runAfter :: P p => Phase
-> a -> p a -> p a
runAfter :: forall (p :: * -> *) a. P p => Phase -> a -> p a -> p a
runAfter = Platform -> Phase -> Phase -> a -> p a -> p a
forall (m :: * -> *) a.
P m =>
Platform -> Phase -> Phase -> a -> m a -> m a
phaseIfAfter Platform
platform (PipeEnv -> Phase
start_phase PipeEnv
pipe_env)
runAfterFlag :: P p
=> HscEnv
-> Phase
-> (DynFlags -> Bool)
-> a
-> p a
-> p a
runAfterFlag :: forall (p :: * -> *) a.
P p =>
HscEnv -> Phase -> (DynFlags -> Bool) -> a -> p a -> p a
runAfterFlag HscEnv
hsc_env Phase
phase DynFlags -> Bool
flag a
def p a
action =
Phase -> a -> p a -> p a
forall (p :: * -> *) a. P p => Phase -> a -> p a -> p a
runAfter Phase
phase a
def
(p a -> p a) -> p a -> p a
forall a b. (a -> b) -> a -> b
$ HscEnv -> (DynFlags -> Bool) -> a -> p a -> p a
forall (m :: * -> *) a.
Monad m =>
HscEnv -> (DynFlags -> Bool) -> a -> m a -> m a
phaseIfFlag HscEnv
hsc_env DynFlags -> Bool
flag a
def p a
action
fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)
fullPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)
fullPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
pp_fn HscSource
src_flavour = do
(DynFlags
dflags, FilePath
input_fn) <- PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
preprocessPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
pp_fn
let hsc_env' :: HscEnv
hsc_env' = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
hsc_env
(HscEnv
hsc_env_with_plugins, ModSummary
mod_sum, HscRecompStatus
hsc_recomp_status)
<- TPhase (HscEnv, ModSummary, HscRecompStatus)
-> m (HscEnv, ModSummary, HscRecompStatus)
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv
-> HscEnv
-> FilePath
-> HscSource
-> TPhase (HscEnv, ModSummary, HscRecompStatus)
T_HscRecomp PipeEnv
pipe_env HscEnv
hsc_env' FilePath
input_fn HscSource
src_flavour)
PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> m (ModIface, Maybe Linkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> m (ModIface, Maybe Linkable)
hscPipeline PipeEnv
pipe_env (HscEnv
hsc_env_with_plugins, ModSummary
mod_sum, HscRecompStatus
hsc_recomp_status)
hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable)
hscPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> m (ModIface, Maybe Linkable)
hscPipeline PipeEnv
pipe_env (HscEnv
hsc_env_with_plugins, ModSummary
mod_sum, HscRecompStatus
hsc_recomp_status) = do
case HscRecompStatus
hsc_recomp_status of
HscUpToDate ModIface
iface Maybe Linkable
mb_linkable -> (ModIface, Maybe Linkable) -> m (ModIface, Maybe Linkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
iface, Maybe Linkable
mb_linkable)
HscRecompNeeded Maybe Fingerprint
mb_old_hash -> do
(FrontendResult
tc_result, Messages GhcMessage
warnings) <- TPhase (FrontendResult, Messages GhcMessage)
-> m (FrontendResult, Messages GhcMessage)
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (HscEnv
-> ModSummary -> TPhase (FrontendResult, Messages GhcMessage)
T_Hsc HscEnv
hsc_env_with_plugins ModSummary
mod_sum)
HscBackendAction
hscBackendAction <- TPhase HscBackendAction -> m HscBackendAction
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (HscEnv
-> ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> TPhase HscBackendAction
T_HscPostTc HscEnv
hsc_env_with_plugins ModSummary
mod_sum FrontendResult
tc_result Messages GhcMessage
warnings Maybe Fingerprint
mb_old_hash )
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
hscBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env_with_plugins ModSummary
mod_sum HscBackendAction
hscBackendAction
hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable)
hscBackendPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
hscBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env ModSummary
mod_sum HscBackendAction
result =
case DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
Backend
NoBackend ->
case HscBackendAction
result of
HscUpdate ModIface
iface -> (ModIface, Maybe Linkable) -> m (ModIface, Maybe Linkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
iface, Maybe Linkable
forall a. Maybe a
Nothing)
HscRecomp {} -> (,) (ModIface -> Maybe Linkable -> (ModIface, Maybe Linkable))
-> m ModIface -> m (Maybe Linkable -> (ModIface, Maybe Linkable))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ModIface -> m ModIface
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv
-> PartialModIface
-> Maybe StgCgInfos
-> Maybe CmmCgInfos
-> IO ModIface
mkFullIface HscEnv
hsc_env (HscBackendAction -> PartialModIface
hscs_partial_iface HscBackendAction
result) Maybe StgCgInfos
forall a. Maybe a
Nothing Maybe CmmCgInfos
forall a. Maybe a
Nothing) m (Maybe Linkable -> (ModIface, Maybe Linkable))
-> m (Maybe Linkable) -> m (ModIface, Maybe Linkable)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Linkable -> m (Maybe Linkable)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Linkable
forall a. Maybe a
Nothing
Backend
_ -> do
(ModIface, Maybe Linkable)
res <- PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
hscGenBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env ModSummary
mod_sum HscBackendAction
result
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let dflags' :: DynFlags
dflags' = DynFlags -> DynFlags
setDynamicNow (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
() () -> m (ModIface, Maybe Linkable) -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
hscGenBackendPipeline PipeEnv
pipe_env ((() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags' HscEnv
hsc_env) ModSummary
mod_sum HscBackendAction
result
(ModIface, Maybe Linkable) -> m (ModIface, Maybe Linkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface, Maybe Linkable)
res
hscGenBackendPipeline :: P m
=> PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
hscGenBackendPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, Maybe Linkable)
hscGenBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env ModSummary
mod_sum HscBackendAction
result = do
let mod_name :: ModuleName
mod_name = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod_sum)
src_flavour :: HscSource
src_flavour = (ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum)
let location :: ModLocation
location = ModSummary -> ModLocation
ms_location ModSummary
mod_sum
([FilePath]
fos, ModIface
miface, Maybe Linkable
mlinkable, FilePath
o_file) <- TPhase ([FilePath], ModIface, Maybe Linkable, FilePath)
-> m ([FilePath], ModIface, Maybe Linkable, FilePath)
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv
-> HscEnv
-> ModuleName
-> HscSource
-> ModLocation
-> HscBackendAction
-> TPhase ([FilePath], ModIface, Maybe Linkable, FilePath)
T_HscBackend PipeEnv
pipe_env HscEnv
hsc_env ModuleName
mod_name HscSource
src_flavour ModLocation
location HscBackendAction
result)
Maybe FilePath
final_fp <- PipeEnv
-> HscEnv
-> HscSource
-> Backend
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> HscSource
-> Backend
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
hscPostBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env (ModSummary -> HscSource
ms_hsc_src ModSummary
mod_sum) (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) (ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
location) FilePath
o_file
Maybe Linkable
final_linkable <-
case Maybe FilePath
final_fp of
Maybe FilePath
Nothing -> Maybe Linkable -> m (Maybe Linkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Linkable
mlinkable
Just FilePath
o_fp -> do
UTCTime
unlinked_time <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IO UTCTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime)
Unlinked
final_unlinked <- FilePath -> Unlinked
DotO (FilePath -> Unlinked) -> m FilePath -> m Unlinked
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> [FilePath] -> TPhase FilePath
T_MergeForeign PipeEnv
pipe_env HscEnv
hsc_env FilePath
o_fp [FilePath]
fos)
let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
unlinked_time (ModSummary -> Module
ms_mod ModSummary
mod_sum) [Unlinked
final_unlinked]
Maybe Linkable -> m (Maybe Linkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable)
(ModIface, Maybe Linkable) -> m (ModIface, Maybe Linkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
miface, Maybe Linkable
final_linkable)
asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)
asPipeline :: forall (m :: * -> *).
P m =>
Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
asPipeline Bool
use_cpp PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
input_fn =
case PipeEnv -> StopPhase
stop_phase PipeEnv
pipe_env of
StopPhase
StopAs -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
StopPhase
_ -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> m FilePath -> m (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> TPhase FilePath
T_As Bool
use_cpp PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
input_fn)
viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
viaCPipeline :: forall (m :: * -> *).
P m =>
Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
viaCPipeline Phase
c_phase PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
input_fn = do
FilePath
out_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (Phase -> PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_Cc Phase
c_phase PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn)
case PipeEnv -> StopPhase
stop_phase PipeEnv
pipe_env of
StopPhase
StopC -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
StopPhase
_ -> Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
asPipeline Bool
False PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
out_fn
llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
fp = do
FilePath
opt_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_LlvmOpt PipeEnv
pipe_env HscEnv
hsc_env FilePath
fp)
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmLlcPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
opt_fn
llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmLlcPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmLlcPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
opt_fn = do
FilePath
llc_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_LlvmLlc PipeEnv
pipe_env HscEnv
hsc_env FilePath
opt_fn)
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmManglePipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
llc_fn
llvmManglePipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmManglePipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmManglePipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
llc_fn = do
FilePath
mangled_fn <-
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoLlvmMangler (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
then FilePath -> m FilePath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
llc_fn
else TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_LlvmMangle PipeEnv
pipe_env HscEnv
hsc_env FilePath
llc_fn)
Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
asPipeline Bool
False PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
mangled_fn
cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmCppPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmCppPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn = do
FilePath
output_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_CmmCpp PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn)
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
output_fn
cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn = do
([FilePath]
fos, FilePath
output_fn) <- TPhase ([FilePath], FilePath) -> m ([FilePath], FilePath)
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath)
T_Cmm PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn)
Maybe FilePath
mo_fn <- PipeEnv
-> HscEnv
-> HscSource
-> Backend
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> HscSource
-> Backend
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
hscPostBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env HscSource
HsSrcFile (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) Maybe ModLocation
forall a. Maybe a
Nothing FilePath
output_fn
case Maybe FilePath
mo_fn of
Maybe FilePath
Nothing -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
Just FilePath
mo_fn -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> m FilePath -> m (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall (f :: * -> *) (m :: * -> *) a. MonadUse f m => f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> [FilePath] -> TPhase FilePath
T_MergeForeign PipeEnv
pipe_env HscEnv
hsc_env FilePath
mo_fn [FilePath]
fos)
hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
hscPostBackendPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> HscSource
-> Backend
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
hscPostBackendPipeline PipeEnv
_ HscEnv
_ HscSource
HsBootFile Backend
_ Maybe ModLocation
_ FilePath
_ = Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
hscPostBackendPipeline PipeEnv
_ HscEnv
_ HscSource
HsigFile Backend
_ Maybe ModLocation
_ FilePath
_ = Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
hscPostBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env HscSource
_ Backend
bcknd Maybe ModLocation
ml FilePath
input_fn =
case Backend
bcknd of
Backend
ViaC -> Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
viaCPipeline Phase
HCc PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
ml FilePath
input_fn
Backend
NCG -> Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
asPipeline Bool
False PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
ml FilePath
input_fn
Backend
LLVM -> PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
ml FilePath
input_fn
Backend
NoBackend -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
Backend
Interpreter -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)
pipelineStart :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)
pipelineStart PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn Maybe Phase
mb_phase =
Phase -> m (Maybe FilePath)
forall (m :: * -> *). P m => Phase -> m (Maybe FilePath)
fromPhase (Phase -> Maybe Phase -> Phase
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Phase
startPhase (FilePath -> Phase) -> FilePath -> Phase
forall a b. (a -> b) -> a -> b
$ PipeEnv -> FilePath
src_suffix PipeEnv
pipe_env) Maybe Phase
mb_phase)
where
stop_after :: StopPhase
stop_after = PipeEnv -> StopPhase
stop_phase PipeEnv
pipe_env
frontend :: P m => HscSource -> m (Maybe FilePath)
frontend :: forall (m :: * -> *). P m => HscSource -> m (Maybe FilePath)
frontend HscSource
sf = case StopPhase
stop_after of
StopPhase
StopPreprocess -> do
(DynFlags
_, FilePath
out_fn) <- PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
preprocessPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
FilePath
final_fn <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> IO FilePath
phaseOutputFilenameNew (HscSource -> Phase
Hsc HscSource
HsSrcFile) PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
forall a. Maybe a
Nothing
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath
final_fn FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
out_fn) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let msg :: FilePath
msg = FilePath
"Copying `" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
out_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 :: FilePath
line_prag = FilePath
"{-# LINE 1 \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PipeEnv -> FilePath
src_filename PipeEnv
pipe_env FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\" #-}\n"
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> FilePath -> IO ()
showPass Logger
logger FilePath
msg)
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> FilePath -> IO ()
copyWithHeader FilePath
line_prag FilePath
out_fn FilePath
final_fn)
Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
StopPhase
_ -> (ModIface, Maybe Linkable) -> Maybe FilePath
forall {a}. (a, Maybe Linkable) -> Maybe FilePath
objFromLinkable ((ModIface, Maybe Linkable) -> Maybe FilePath)
-> m (ModIface, Maybe Linkable) -> m (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PipeEnv
-> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)
fullPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn HscSource
sf
c :: P m => Phase -> m (Maybe FilePath)
c :: forall (m :: * -> *). P m => Phase -> m (Maybe FilePath)
c Phase
phase = Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
Phase
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
viaCPipeline Phase
phase PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
forall a. Maybe a
Nothing FilePath
input_fn
as :: P m => Bool -> m (Maybe FilePath)
as :: forall (m :: * -> *). P m => Bool -> m (Maybe FilePath)
as Bool
use_cpp = Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
asPipeline Bool
use_cpp PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
forall a. Maybe a
Nothing FilePath
input_fn
objFromLinkable :: (a, Maybe Linkable) -> Maybe FilePath
objFromLinkable (a
_, Just (LM UTCTime
_ Module
_ [DotO FilePath
lnk])) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
lnk
objFromLinkable (a, Maybe Linkable)
_ = Maybe FilePath
forall a. Maybe a
Nothing
fromPhase :: P m => Phase -> m (Maybe FilePath)
fromPhase :: forall (m :: * -> *). P m => Phase -> m (Maybe FilePath)
fromPhase (Unlit HscSource
p) = HscSource -> m (Maybe FilePath)
forall (m :: * -> *). P m => HscSource -> m (Maybe FilePath)
frontend HscSource
p
fromPhase (Cpp HscSource
p) = HscSource -> m (Maybe FilePath)
forall (m :: * -> *). P m => HscSource -> m (Maybe FilePath)
frontend HscSource
p
fromPhase (HsPp HscSource
p) = HscSource -> m (Maybe FilePath)
forall (m :: * -> *). P m => HscSource -> m (Maybe FilePath)
frontend HscSource
p
fromPhase (Hsc HscSource
p) = HscSource -> m (Maybe FilePath)
forall (m :: * -> *). P m => HscSource -> m (Maybe FilePath)
frontend HscSource
p
fromPhase Phase
HCc = Phase -> m (Maybe FilePath)
forall (m :: * -> *). P m => Phase -> m (Maybe FilePath)
c Phase
HCc
fromPhase Phase
Cc = Phase -> m (Maybe FilePath)
forall (m :: * -> *). P m => Phase -> m (Maybe FilePath)
c Phase
Cc
fromPhase Phase
Ccxx = Phase -> m (Maybe FilePath)
forall (m :: * -> *). P m => Phase -> m (Maybe FilePath)
c Phase
Ccxx
fromPhase Phase
Cobjc = Phase -> m (Maybe FilePath)
forall (m :: * -> *). P m => Phase -> m (Maybe FilePath)
c Phase
Cobjc
fromPhase Phase
Cobjcxx = Phase -> m (Maybe FilePath)
forall (m :: * -> *). P m => Phase -> m (Maybe FilePath)
c Phase
Cobjcxx
fromPhase (As Bool
p) = Bool -> m (Maybe FilePath)
forall (m :: * -> *). P m => Bool -> m (Maybe FilePath)
as Bool
p
fromPhase Phase
LlvmOpt = PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
forall a. Maybe a
Nothing FilePath
input_fn
fromPhase Phase
LlvmLlc = PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmLlcPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
forall a. Maybe a
Nothing FilePath
input_fn
fromPhase Phase
LlvmMangle = PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmManglePipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
forall a. Maybe a
Nothing FilePath
input_fn
fromPhase Phase
StopLn = Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
input_fn)
fromPhase Phase
CmmCpp = PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmCppPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn
fromPhase Phase
Cmm = PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn
fromPhase Phase
MergeForeign = FilePath -> m (Maybe FilePath)
forall a. FilePath -> a
panic FilePath
"fromPhase: MergeForeign"