{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}

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

module GHC.Driver.Pipeline (
   -- * Run a series of compilation steps in a pipeline, for a
   -- collection of source files.
   oneShot, compileFile,

   -- * Interfaces for the compilation manager (interpreted/batch-mode)
   preprocess,
   compileOne, compileOne',
   compileForeign, compileEmptyStub,

   -- * Linking
   link, linkingNeeded, checkLinkInfo,

   -- * PipeEnv
   PipeEnv(..), mkPipeEnv, phaseOutputFilenameNew,

   -- * Running individual phases
   TPhase(..), runPhase,
   hscPostBackendPhase,

   -- * Constructing Pipelines
   TPipelineClass, MonadUse(..),

   preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline,
   hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, jsPipeline,
   llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,

   -- * Default method of running a pipeline
   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.Config.StgToJS
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.SysTools.Cpp
import GHC.Utils.TmpFs

import GHC.Linker.ExtraObj
import GHC.Linker.Static
import GHC.Linker.Static.Utils
import GHC.Linker.Types

import GHC.StgToJS.Linker.Linker
import GHC.StgToJS.Linker.Types (defaultJSLinkConfig)

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, UnknownDiagnostic (..) )
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.Finder
--import GHC.Unit.State
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

-- Simpler type synonym for actions in the pipeline monad
type P m = TPipelineClass TPhase m

-- ---------------------------------------------------------------------------
-- Pre-process

-- | Just preprocess a file, put the result in a temp. file (used by the
-- compilation manager during the summary phase).
--
-- We return the augmented DynFlags, because they contain the result
-- of slurping in the OPTIONS pragmas

preprocess :: HscEnv
           -> FilePath -- ^ input filename
           -> Maybe InputFileBuffer
           -- ^ optional buffer to use instead of reading the input file
           -> Maybe Phase -- ^ starting phase
           -> IO (Either 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.
(HasCallStack, 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
forall doc. IsLine doc => FilePath -> doc
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
$
        UnknownDiagnostic -> DriverMessage
DriverUnknownMessage (UnknownDiagnostic -> DriverMessage)
-> UnknownDiagnostic -> DriverMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
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
forall doc. IsLine doc => FilePath -> doc
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"
                             -- MP: Default config is fine here as it's just in a panic.
                             ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticOpts GhcMessage -> Bag (MsgEnvelope GhcMessage) -> [SDoc]
forall e.
Diagnostic e =>
DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @GhcMessage) (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
          -- Add a LINE pragma so reported source locations will
          -- mention the real input file, not this temp file.
          Handle -> FilePath -> IO ()
hPutStrLn Handle
hdl (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ 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

-- ---------------------------------------------------------------------------

-- | Compile
--
-- Compile a single module, under the control of the compilation manager.
--
-- This is the interface between the compilation manager and the
-- compiler proper (hsc), where we deal with tedious details like
-- reading the OPTIONS pragma from the source file, converting the
-- C or assembly that GHC produces into an object file, and compiling
-- FFI stub files.
--
-- NB.  No old interface can also mean that the source has changed.


compileOne :: HscEnv
           -> ModSummary      -- ^ summary for module being compiled
           -> Int             -- ^ module N ...
           -> Int             -- ^ ... of M
           -> Maybe ModIface  -- ^ old interface, if we have one
           -> HomeModLinkable  -- ^ old linkable, if we have one
           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful

compileOne :: HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> HomeModLinkable
-> IO HomeModInfo
compileOne = Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> HomeModLinkable
-> IO HomeModInfo
compileOne' (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
batchMsg)

compileOne' :: Maybe Messager
            -> HscEnv
            -> ModSummary      -- ^ summary for module being compiled
            -> Int             -- ^ module N ...
            -> Int             -- ^ ... of M
            -> Maybe ModIface  -- ^ old interface, if we have one
            -> HomeModLinkable
            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful

compileOne' :: Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> HomeModLinkable
-> IO HomeModInfo
compileOne' Maybe Messager
mHscMessage
            HscEnv
hsc_env0 ModSummary
summary Int
mod_index Int
nmods Maybe ModIface
mb_old_iface HomeModLinkable
mb_old_linkable
 = do

   Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"compile: input file" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
input_fnpp)

   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepHiFiles DynFlags
lcl_dflags) (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
lcl_dflags) (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
-> HomeModLinkable
-> (Int, Int)
-> IO HscRecompStatus
hscRecompStatus Maybe Messager
mHscMessage HscEnv
plugin_hsc_env ModSummary
upd_summary
                Maybe ModIface
mb_old_iface HomeModLinkable
mb_old_linkable (Int
mod_index, Int
nmods)
   let pipeline :: HookedUse (ModIface, HomeModLinkable)
pipeline = PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> HookedUse (ModIface, HomeModLinkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> m (ModIface, HomeModLinkable)
hscPipeline PipeEnv
pipe_env (PipeEnv -> HscEnv -> HscEnv
setDumpPrefix PipeEnv
pipe_env HscEnv
plugin_hsc_env, ModSummary
upd_summary, HscRecompStatus
status)
   (ModIface
iface, HomeModLinkable
linkable) <- Hooks
-> HookedUse (ModIface, HomeModLinkable)
-> IO (ModIface, HomeModLinkable)
forall a. Hooks -> HookedUse a -> IO a
runPipeline (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) HookedUse (ModIface, HomeModLinkable)
pipeline
   -- See Note [ModDetails and --make mode]
   ModDetails
details <- HscEnv -> ModIface -> IO ModDetails
initModDetails HscEnv
plugin_hsc_env ModIface
iface
   Maybe Linkable
linkable' <- (Linkable -> IO Linkable) -> Maybe Linkable -> IO (Maybe Linkable)
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) -> Maybe a -> f (Maybe b)
traverse (HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
initWholeCoreBindings HscEnv
plugin_hsc_env ModIface
iface ModDetails
details) (HomeModLinkable -> Maybe Linkable
homeMod_bytecode HomeModLinkable
linkable)
   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 -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details (HomeModLinkable
linkable { homeMod_bytecode = 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 = Backend -> PipelineOutput
backendPipelineOutput Backend
bcknd

       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

       -- We add the directory in which the .hs files resides) to the import
       -- path.  This is needed when we try to compile the .hc file later, if it
       -- imports a _stub.h file that we created here.
       current_dir :: FilePath
current_dir = FilePath -> FilePath
takeDirectory FilePath
basename
       old_paths :: IncludeSpecs
old_paths   = DynFlags -> IncludeSpecs
includePaths DynFlags
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
       -- Figure out which backend we're using
       (Backend
bcknd, DynFlags
dflags3)
         -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags
         -- suggest to generate object code (which may happen in case -fobject-code
         -- was set), force it to generate byte-code. This is NOT transitive and
         -- only applies to direct targets.
         | Bool
loadAsByteCode
         = ( Backend
interpreterBackend
           , DynFlags -> GeneralFlag -> DynFlags
gopt_set (DynFlags
lcl_dflags { backend = interpreterBackend }) GeneralFlag
Opt_ForceRecomp
           )

         | Bool
otherwise
         = (DynFlags -> Backend
backend DynFlags
dflags, DynFlags
lcl_dflags)
       -- See Note [Filepaths and Multiple Home Units]
       dflags :: DynFlags
dflags  = DynFlags
dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }
       upd_summary :: ModSummary
upd_summary = ModSummary
summary { ms_hspp_opts = dflags }
       hsc_env :: HscEnv
hsc_env = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
hsc_env0


-- ---------------------------------------------------------------------------
-- Link
--
-- Note [Dynamic linking on macOS]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Since macOS Sierra (10.14), the dynamic system linker enforces
-- a limit on the Load Commands.  Specifically the Load Command Size
-- Limit is at 32K (32768).  The Load Commands contain the install
-- name, dependencies, runpaths, and a few other commands.  We however
-- only have control over the install name, dependencies and runpaths.
--
-- The install name is the name by which this library will be
-- referenced.  This is such that we do not need to bake in the full
-- absolute location of the library, and can move the library around.
--
-- The dependency commands contain the install names from of referenced
-- libraries.  Thus if a libraries install name is @rpath/libHS...dylib,
-- that will end up as the dependency.
--
-- Finally we have the runpaths, which informs the linker about the
-- directories to search for the referenced dependencies.
--
-- The system linker can do recursive linking, however using only the
-- direct dependencies conflicts with ghc's ability to inline across
-- packages, and as such would end up with unresolved symbols.
--
-- Thus we will pass the full dependency closure to the linker, and then
-- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).
--
-- We still need to add the relevant runpaths, for the dynamic linker to
-- lookup the referenced libraries though.  The linker (ld64) does not
-- have any option to dead strip runpaths; which makes sense as runpaths
-- can be used for dependencies of dependencies as well.
--
-- The solution we then take in GHC is to not pass any runpaths to the
-- linker at link time, but inject them after the linking.  For this to
-- work we'll need to ask the linker to create enough space in the header
-- to add more runpaths after the linking (-headerpad 8000).
--
-- After the library has been linked by $LD (usually ld64), we will use
-- otool to inspect the libraries left over after dead stripping, compute
-- the relevant runpaths, and inject them into the linked product using
-- the install_name_tool command.
--
-- This strategy should produce the smallest possible set of load commands
-- while still retaining some form of relocatability via runpaths.
--
-- The only way I can see to reduce the load command size further would be
-- by shortening the library names, or start putting libraries into the same
-- folders, such that one runpath would be sufficient for multiple/all
-- libraries.
link :: GhcLink                 -- ^ interactive or batch
     -> Logger                  -- ^ Logger
     -> TmpFs
     -> Hooks
     -> DynFlags                -- ^ dynamic flags
     -> UnitEnv                 -- ^ unit environment
     -> Bool                    -- ^ attempt linking in batch mode?
     -> Maybe (RecompileRequired -> IO ())
     -> HomePackageTable        -- ^ what to link
     -> IO SuccessFlag

-- For the moment, in the batch linker, we don't bother to tell doLink
-- which packages to link -- it just tries all that are available.
-- batch_attempt_linking should only be *looked at* in batch mode.  It
-- should only be True if the upsweep was successful and someone
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.

link :: GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> 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
           -- Not Linking...(demand linker will do the job)
            -> 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. HasCallStack => 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                -- ^ dynamic flags
      -> UnitEnv                 -- ^ unit environment
      -> Bool                    -- ^ attempt linking in batch mode?
      -> Maybe (RecompileRequired -> IO ())
      -> HomePackageTable        -- ^ what to link
      -> 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

            -- the packages we depend on
            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

            -- the linkables to link
            linkables :: [Linkable]
linkables = (HomeModInfo -> Linkable) -> [HomeModInfo] -> [Linkable]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe Linkable -> Linkable
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"link"(Maybe Linkable -> Linkable)
-> (HomeModInfo -> Maybe Linkable) -> HomeModInfo -> Linkable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> Maybe Linkable
homeModInfoObject) [HomeModInfo]
home_mod_infos

        Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"link: hmi ..." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((HomeModInfo -> SDoc) -> [HomeModInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> SDoc) -> (HomeModInfo -> Module) -> HomeModInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
home_mod_infos))
        Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"link: linkables are ..." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Linkable -> SDoc) -> [Linkable] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Linkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Linkable]
linkables))
        Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"link: pkg deps are ..." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
pkg_deps))

        -- check for the -no-link flag
        if GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
          then do Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
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
            arch_os :: ArchOS
arch_os   = Platform -> ArchOS
platformArchOS Platform
platform
            exe_file :: FilePath
exe_file  = ArchOS -> Bool -> Maybe FilePath -> FilePath
exeFileName ArchOS
arch_os 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
forall doc. IsLine doc => FilePath -> doc
text FilePath
exe_file SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
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


        -- Don't showPass in Batch mode; doLink will do that for us.
        case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
          GhcLink
LinkBinary
            | Backend -> Bool
backendUseJSLinker (DynFlags -> Backend
backend DynFlags
dflags) -> Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkJSBinary Logger
logger DynFlags
dflags UnitEnv
unit_env [FilePath]
obj_files [UnitId]
pkg_deps
            | Bool
otherwise -> Logger
-> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkBinary Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [FilePath]
obj_files [UnitId]
pkg_deps
          GhcLink
LinkStaticLib -> Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkStaticLib Logger
logger DynFlags
dflags UnitEnv
unit_env [FilePath]
obj_files [UnitId]
pkg_deps
          GhcLink
LinkDynLib    -> Logger
-> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkDynLibCheck Logger
logger TmpFs
tmpfs DynFlags
dflags UnitEnv
unit_env [FilePath]
obj_files [UnitId]
pkg_deps
          GhcLink
other         -> GhcLink -> IO ()
forall a. GhcLink -> a
panicBadLink GhcLink
other

        Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"link: done")

        -- linkBinary only returns if it succeeds
        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
forall doc. IsLine doc => FilePath -> doc
text FilePath
"link(batch): upsweep (partially) failed OR" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                                FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
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


linkJSBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkJSBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkJSBinary Logger
logger DynFlags
dflags UnitEnv
unit_env [FilePath]
obj_files [UnitId]
pkg_deps = do
  -- we use the default configuration for now. In the future we may expose
  -- settings to the user via DynFlags.
  let lc_cfg :: JSLinkConfig
lc_cfg   = JSLinkConfig
defaultJSLinkConfig
  let cfg :: StgToJSConfig
cfg      = DynFlags -> StgToJSConfig
initStgToJSConfig DynFlags
dflags
  let extra_js :: [FilePath]
extra_js = [FilePath]
forall a. Monoid a => a
mempty
  JSLinkConfig
-> StgToJSConfig
-> [FilePath]
-> Logger
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
jsLinkBinary JSLinkConfig
lc_cfg StgToJSConfig
cfg [FilePath]
extra_js Logger
logger DynFlags
dflags UnitEnv
unit_env [FilePath]
obj_files [UnitId]
pkg_deps

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
        -- if the modification time on the executable is later than the
        -- modification times on all of the objects and libraries, then omit
        -- linking (unless the -fforce-recomp flag was given).
  let platform :: Platform
platform   = UnitEnv -> Platform
ue_platform UnitEnv
unit_env
      unit_state :: UnitState
unit_state = (() :: Constraint) => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env
      arch_os :: ArchOS
arch_os    = Platform -> ArchOS
platformArchOS Platform
platform
      exe_file :: FilePath
exe_file   = ArchOS -> Bool -> Maybe FilePath -> FilePath
exeFileName ArchOS
arch_os 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
        -- first check object files and extra_ld_inputs
        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

        -- next, check libraries. XXX this only checks Haskell libraries,
        -- not extra_libraries or -l things from the command line.
        let pkg_hslibs :: [([FilePath], FilePath)]
pkg_hslibs  = [ (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)

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

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      -- Set by -c or -no-link
        notStopPreprocess :: Bool
notStopPreprocess | StopPhase
StopPreprocess <- StopPhase
stop_phase = Bool
False
                          | StopPhase
_              <- StopPhase
stop_phase = Bool
True
        -- When linking, the -o argument refers to the linker's output.
        -- otherwise, we use it as the name for the pipeline's output.
        output :: PipelineOutput
output
         | Bool -> Bool
not (Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend DynFlags
dflags)), Bool
notStopPreprocess = PipelineOutput
NoOutputFile
                -- avoid -E -fno-code undesirable interactions. see #20439
         | StopPhase
NoStop <- StopPhase
stop_phase, Bool -> Bool
not (GhcLink -> Bool
isNoLink GhcLink
ghc_link) = PipelineOutput
Persistent
                -- -o foo applies to linker
         | Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
mb_o_file = PipelineOutput
SpecificFile
                -- -o foo applies to the file we are compiling now
         | Bool
otherwise = PipelineOutput
Persistent
        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 = do
  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

  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
      | Backend -> Bool
backendUseJSLinker (DynFlags -> Backend
backend DynFlags
dflags)
                  -> Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkJSBinary Logger
logger DynFlags
dflags UnitEnv
unit_env [FilePath]
o_files []
      | Bool
otherwise -> 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. HasCallStack => FilePath -> a
panic FilePath
"Output path must be specified for LinkMergedObj"
    GhcLink
other         -> GhcLink -> IO ()
forall a. GhcLink -> a
panicBadLink GhcLink
other

-----------------------------------------------------------------------------
-- stub .h and .c files (for foreign export support), and cc files.

-- The _stub.c file is derived from the haskell source file, possibly taking
-- into account the -stubdir option.
--
-- The object file created by compiling the _stub.c file is put into a
-- temporary file, which will be later combined with the main .o file
-- (see the MergeForeign phase).
--
-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
-- from TH, that are then compiled and linked to the module. This is
-- useful to implement facilities such as inline-c.

compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign 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
              ForeignSrcLang
LangJs     -> \PipeEnv
pe HscEnv
hsc_env Maybe ModLocation
ml FilePath
fp -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath)
-> HookedUse FilePath -> HookedUse (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> HookedUse FilePath
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
foreignJsPipeline 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
          -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.
          -- and the same should never happen for asPipeline
          -- Future refactoring to not check StopC for this case
          Maybe FilePath
Nothing -> FilePath -> SDoc -> IO FilePath
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"compileForeign" (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text 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
  -- To maintain the invariant that every Haskell file
  -- compiles to object code, we make an empty (but
  -- valid) stub object file for signatures.  However,
  -- we make sure this object file has a unique symbol,
  -- so that ranlib on OS X doesn't complain, see
  -- https://gitlab.haskell.org/ghc/ghc/issues/12673
  -- and https://github.com/haskell/cabal/issues/2257
  let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
  let tmpfs :: TmpFs
tmpfs  = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
  let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env

  case Backend -> DefunctionalizedCodeOutput
backendCodeOutput (DynFlags -> Backend
backend DynFlags
dflags) of
    DefunctionalizedCodeOutput
JSCodeOutput -> do
      FilePath
empty_stub <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule FilePath
"js"
      let src :: SDoc
src = Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"= 0;"
      FilePath -> FilePath -> IO ()
writeFile FilePath
empty_stub (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SDoc -> SDoc
pprCode 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 = basename}
          pipeline :: HookedUse (Maybe FilePath)
pipeline = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath)
-> HookedUse FilePath -> HookedUse (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> HookedUse FilePath
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
foreignJsPipeline 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

    DefunctionalizedCodeOutput
_ -> do
      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 src :: SDoc
src = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"int" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"= 0;"
      FilePath -> FilePath -> IO ()
writeFile FilePath
empty_stub (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags (SDoc -> SDoc
pprCode 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 = 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()



{- Environment Initialisation -}

mkPipeEnv :: StopPhase -- End phase
          -> FilePath -- input fn
          -> Maybe Phase
          -> PipelineOutput -- Output
          -> 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 -- strip off the .
      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 = src_basename pipe_env ++ "."}) HscEnv
hsc_env

{- The Pipelines -}

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

-- | Check if the start is *before* the current phase, otherwise skip with a default
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

-- | The preprocessor pipeline
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
          -- Didn't run any preprocessors so don't need to reparse, would be nicer
          -- if `T_FileArgs` recognised this.
          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
            -- Reparse with original hsc_env so that we don't get duplicated options
            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)

  let print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags3
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) DiagnosticOpts GhcMessage
GhcMessageOpts
print_config (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 -> GhcMessageOpts -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) DiagnosticOpts GhcMessage
GhcMessageOpts
print_config (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)


  -- This won't change through the compilation pipeline
  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

-- | The complete compilation pipeline, from start to finish
fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable)
fullPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable)
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, HomeModLinkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> m (ModIface, HomeModLinkable)
hscPipeline PipeEnv
pipe_env (HscEnv
hsc_env_with_plugins, ModSummary
mod_sum, HscRecompStatus
hsc_recomp_status)

-- | Everything after preprocess
hscPipeline :: P m => PipeEnv ->  ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable)
hscPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> (HscEnv, ModSummary, HscRecompStatus)
-> m (ModIface, HomeModLinkable)
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 HomeModLinkable
mb_linkable -> (ModIface, HomeModLinkable) -> m (ModIface, HomeModLinkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
iface, HomeModLinkable
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, HomeModLinkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, HomeModLinkable)
hscBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env_with_plugins ModSummary
mod_sum HscBackendAction
hscBackendAction

hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable)
hscBackendPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, HomeModLinkable)
hscBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env ModSummary
mod_sum HscBackendAction
result =
  if Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) then
    do
      (ModIface, HomeModLinkable)
res <- PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, HomeModLinkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, HomeModLinkable)
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) -- set "dynamicNow"
          () () -> m (ModIface, HomeModLinkable) -> 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, HomeModLinkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, HomeModLinkable)
hscGenBackendPipeline PipeEnv
pipe_env ((() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags' HscEnv
hsc_env) ModSummary
mod_sum HscBackendAction
result
      (ModIface, HomeModLinkable) -> m (ModIface, HomeModLinkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface, HomeModLinkable)
res
  else
    case HscBackendAction
result of
      HscUpdate ModIface
iface ->  (ModIface, HomeModLinkable) -> m (ModIface, HomeModLinkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
iface, HomeModLinkable
emptyHomeModInfoLinkable)
      HscRecomp {} -> (,) (ModIface -> HomeModLinkable -> (ModIface, HomeModLinkable))
-> m ModIface -> m (HomeModLinkable -> (ModIface, HomeModLinkable))
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 (HomeModLinkable -> (ModIface, HomeModLinkable))
-> m HomeModLinkable -> m (ModIface, HomeModLinkable)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HomeModLinkable -> m HomeModLinkable
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HomeModLinkable
emptyHomeModInfoLinkable
    -- TODO: Why is there not a linkable?
    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing

hscGenBackendPipeline :: P m
  => PipeEnv
  -> HscEnv
  -> ModSummary
  -> HscBackendAction
  -> m (ModIface, HomeModLinkable)
hscGenBackendPipeline :: forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, HomeModLinkable)
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, HomeModLinkable
mlinkable, FilePath
o_file) <- TPhase ([FilePath], ModIface, HomeModLinkable, FilePath)
-> m ([FilePath], ModIface, HomeModLinkable, 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, HomeModLinkable, 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
  HomeModLinkable
final_linkable <-
    case Maybe FilePath
final_fp of
      -- No object file produced, bytecode or NoBackend
      Maybe FilePath
Nothing -> HomeModLinkable -> m HomeModLinkable
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModLinkable
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]
        -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.
        HomeModLinkable -> m HomeModLinkable
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModLinkable
mlinkable { homeMod_object = Just linkable })
  (ModIface, HomeModLinkable) -> m (ModIface, HomeModLinkable)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
miface, HomeModLinkable
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
-> Maybe ModLocation
-> FilePath
-> TPhase FilePath
T_Cc Phase
c_phase PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location 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
_ -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> m (Maybe FilePath))
-> Maybe FilePath -> m (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just 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 FilePath
cmmCppPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m 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 FilePath
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m FilePath
cmmPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
output_fn

cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath
cmmPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m 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 -> FilePath -> m FilePath
forall a. HasCallStack => FilePath -> a
panic FilePath
"CMM pipeline - produced no .o file"
    Just FilePath
mo_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 -> [FilePath] -> TPhase FilePath
T_MergeForeign PipeEnv
pipe_env HscEnv
hsc_env FilePath
mo_fn [FilePath]
fos)

jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
jsPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
jsPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
input_fn = 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 -> Maybe ModLocation -> FilePath -> TPhase FilePath
T_Js PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
input_fn)

foreignJsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
foreignJsPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
foreignJsPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
input_fn = 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 -> Maybe ModLocation -> FilePath -> TPhase FilePath
T_ForeignJs PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
location FilePath
input_fn)

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 =
  DefunctionalizedPostHscPipeline
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
forall (m :: * -> *).
TPipelineClass TPhase m =>
DefunctionalizedPostHscPipeline
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
applyPostHscPipeline (Backend -> DefunctionalizedPostHscPipeline
backendPostHscPipeline Backend
bcknd) PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
ml FilePath
input_fn

applyPostHscPipeline
    :: TPipelineClass TPhase m
    => DefunctionalizedPostHscPipeline
    -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
applyPostHscPipeline :: forall (m :: * -> *).
TPipelineClass TPhase m =>
DefunctionalizedPostHscPipeline
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
applyPostHscPipeline DefunctionalizedPostHscPipeline
NcgPostHscPipeline =
    \PipeEnv
pe HscEnv
he Maybe ModLocation
ml FilePath
fp -> 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
pe HscEnv
he Maybe ModLocation
ml FilePath
fp
applyPostHscPipeline DefunctionalizedPostHscPipeline
ViaCPostHscPipeline = 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
applyPostHscPipeline DefunctionalizedPostHscPipeline
LlvmPostHscPipeline =
    \PipeEnv
pe HscEnv
he Maybe ModLocation
ml FilePath
fp -> PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
llvmPipeline PipeEnv
pe HscEnv
he Maybe ModLocation
ml FilePath
fp
applyPostHscPipeline DefunctionalizedPostHscPipeline
JSPostHscPipeline =
    \PipeEnv
pe HscEnv
he Maybe ModLocation
ml FilePath
fp -> 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
<$> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
jsPipeline PipeEnv
pe HscEnv
he Maybe ModLocation
ml FilePath
fp
applyPostHscPipeline DefunctionalizedPostHscPipeline
NoPostHscPipeline = \PipeEnv
_ HscEnv
_ 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

-- Pipeline from a given suffix
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
                      -- The actual output from preprocessing
                      (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
                      -- Sometimes, a compilation phase doesn't actually generate any output
                      -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
                      -- stage, but we wanted to keep the output, then we have to explicitly
                      -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
                      -- further compilation stages can tell what the original filename was.
                      -- File name we expected the output to have
                      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, HomeModLinkable) -> Maybe FilePath
forall {a}. (a, HomeModLinkable) -> Maybe FilePath
objFromLinkable ((ModIface, HomeModLinkable) -> Maybe FilePath)
-> m (ModIface, HomeModLinkable) -> m (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PipeEnv
-> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable)
forall (m :: * -> *).
P m =>
PipeEnv
-> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable)
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, HomeModLinkable) -> Maybe FilePath
objFromLinkable (a
_, HomeModLinkable -> Maybe Linkable
homeMod_object -> Just (LM UTCTime
_ Module
_ [DotO FilePath
lnk])) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
lnk
   objFromLinkable (a, HomeModLinkable)
_ = 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     = 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
<$> PipeEnv -> HscEnv -> FilePath -> m FilePath
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m FilePath
cmmCppPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn
   fromPhase Phase
Cmm        = 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
<$> PipeEnv -> HscEnv -> FilePath -> m FilePath
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m FilePath
cmmPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn
   fromPhase Phase
Js         = 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
<$> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
foreignJsPipeline PipeEnv
pipe_env HscEnv
hsc_env Maybe ModLocation
forall a. Maybe a
Nothing FilePath
input_fn
   fromPhase Phase
MergeForeign = FilePath -> m (Maybe FilePath)
forall a. HasCallStack => FilePath -> a
panic FilePath
"fromPhase: MergeForeign"

{-
Note [The Pipeline Monad]
~~~~~~~~~~~~~~~~~~~~~~~~~
The pipeline is represented as a free monad by the `TPipelineClass` type synonym,
which stipulates the general monadic interface for the pipeline and `MonadUse`, instantiated
to `TPhase`, which indicates the actions available in the pipeline.

The `TPhase` actions correspond to different compiled phases, they are executed by
the 'runPhase' function which interprets each action into IO.

The idea in the future is that we can now implement different instiations of
`TPipelineClass` to give different behaviours that the default `HookedPhase` implementation:

* Additional logging of different phases
* Automatic parallelism (in the style of shake)
* Easy consumption by external tools such as ghcide
* Easier to create your own pipeline and extend existing pipelines.

The structure of the code as a free monad also means that the return type of each
phase is a lot more flexible.

-}