{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ViewPatterns #-}

-----------------------------------------------------------------------------
--
-- 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.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, mkSimpleUnknownDiagnostic, defaultDiagnosticOpts )
import GHC.Types.ForeignStubs (ForeignStubs (NoStubs))
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 qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))

import Data.Time        ( getCurrentTime )
import GHC.Iface.Recomp
import GHC.Types.Unique.DSet

-- 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)
  input_fn_final <- IO FilePath
mkInputFn
  let 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
  runPipeline (hsc_hooks hsc_env) 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 (DiagnosticOpts DriverMessage) -> DriverMessage
DriverUnknownMessage (UnknownDiagnostic (DiagnosticOpts DriverMessage) -> DriverMessage)
-> UnknownDiagnostic (DiagnosticOpts DriverMessage)
-> DriverMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts DriverMessage)
forall a b.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic (DiagnosticMessage
 -> UnknownDiagnostic (DiagnosticOpts DriverMessage))
-> DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts DriverMessage)
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
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 opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
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
          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)
          hdl <- openBinaryFile fn WriteMode
          -- Add a LINE pragma so reported source locations will
          -- mention the real input file, not this temp file.
          hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"
          hPutStringBuffer hdl input_buf
          hClose hdl
          return 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]

   -- Initialise plugins here for any plugins enabled locally for a module.
   plugin_hsc_env <- HscEnv -> IO HscEnv
initializePlugins HscEnv
hsc_env
   let pipe_env = StopPhase -> FilePath -> Maybe Phase -> PipelineOutput -> PipeEnv
mkPipeEnv StopPhase
NoStop FilePath
input_fn Maybe Phase
forall a. Maybe a
Nothing PipelineOutput
pipelineOutput
   status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary
                mb_old_iface mb_old_linkable (mod_index, nmods)
   let 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)
   (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline
   -- See Note [ModDetails and --make mode]
   details <- initModDetails plugin_hsc_env iface
   linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable)
   return $! HomeModInfo iface details (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. HasDebugCallStack => 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 = HasDebugCallStack => 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
     -> FinderCache
     -> 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
-> FinderCache
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link GhcLink
ghcLink Logger
logger TmpFs
tmpfs FinderCache
fc 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
-> FinderCache
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link' Logger
logger TmpFs
tmpfs FinderCache
fc 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
      -> FinderCache
      -> DynFlags                -- ^ dynamic flags
      -> UnitEnv                 -- ^ unit environment
      -> Bool                    -- ^ attempt linking in batch mode?
      -> Maybe (RecompileRequired -> IO ())
      -> HomePackageTable        -- ^ what to link
      -> IO SuccessFlag

link' :: Logger
-> TmpFs
-> FinderCache
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link' Logger
logger TmpFs
tmpfs FinderCache
fc 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. HasDebugCallStack => 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 obj_files :: [FilePath]
obj_files = (Linkable -> [FilePath]) -> [Linkable] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Linkable -> [FilePath]
linkableObjs [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)

        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

        forM_ mHscMessager $ \RecompileRequired -> IO ()
hscMessage -> RecompileRequired -> IO ()
hscMessage RecompileRequired
linking_needed
        if not (gopt Opt_ForceRecomp dflags) && (linking_needed == UpToDate)
           then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.")
                   return Succeeded
           else do


        -- Don't showPass in Batch mode; doLink will do that for us.
        case ghcLink dflags of
          GhcLink
LinkBinary
            | Backend -> Bool
backendUseJSLinker (DynFlags -> Backend
backend DynFlags
dflags) -> Logger
-> TmpFs
-> FinderCache
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
linkJSBinary Logger
logger TmpFs
tmpfs FinderCache
fc 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

        debugTraceMsg logger 3 (text "link: done")

        -- linkBinary only returns if it succeeds
        return 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 -> TmpFs -> FinderCache -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
linkJSBinary :: Logger
-> TmpFs
-> FinderCache
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
linkJSBinary Logger
logger TmpFs
tmpfs FinderCache
fc 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   = DynFlags -> JSLinkConfig
initJSLinkConfig DynFlags
dflags
  let cfg :: StgToJSConfig
cfg      = DynFlags -> StgToJSConfig
initStgToJSConfig DynFlags
dflags
  FinderCache
-> JSLinkConfig
-> StgToJSConfig
-> Logger
-> TmpFs
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
jsLinkBinary FinderCache
fc JSLinkConfig
lc_cfg StgToJSConfig
cfg Logger
logger TmpFs
tmpfs 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 = HasDebugCallStack => 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)
  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 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 ]
        (errs,extra_times) <- (FilePath -> IO (Either IOException UTCTime))
-> [FilePath] -> IO ([IOException], [UTCTime])
forall (m :: * -> *) a b c.
Monad m =>
(a -> m (Either b c)) -> [a] -> m ([b], [c])
partitionWithM (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 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 not (null errs) || any (t <) obj_times
            then return $ needsRecompileBecause ObjectsChanged
            else do

        -- next, check libraries. XXX this only checks Haskell libraries,
        -- not extra_libraries or -l things from the command line.
        -- pkg_deps is just the direct dependencies so take the transitive closure here
        -- to decide if we need to relink or not.
        let pkg_hslibs UniqDSet UnitId
acc UnitId
uid
              | UnitId
uid UnitId -> UniqDSet UnitId -> Bool
forall a. Uniquable a => a -> UniqDSet a -> Bool
`elementOfUniqDSet` UniqDSet UnitId
acc = UniqDSet UnitId
acc
              | Just UnitInfo
c <- UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
unit_state UnitId
uid =
                  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' @[] UniqDSet UnitId -> UnitId -> UniqDSet UnitId
pkg_hslibs (UniqDSet UnitId -> UnitId -> UniqDSet UnitId
forall a. Uniquable a => UniqDSet a -> a -> UniqDSet a
addOneToUniqDSet UniqDSet UnitId
acc UnitId
uid) (UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
c)
              | Bool
otherwise = UniqDSet UnitId
acc

            all_pkg_deps = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' @[] UniqDSet UnitId -> UnitId -> UniqDSet UnitId
pkg_hslibs UniqDSet UnitId
forall a. UniqDSet a
emptyUniqDSet [UnitId]
pkg_deps

        let 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) (UniqDSet UnitId -> [UnitId]
forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet UnitId
all_pkg_deps),
                            FilePath
lib <- GhcNameVersion -> Ways -> UnitInfo -> [FilePath]
unitHsLibs (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Ways
ways DynFlags
dflags) UnitInfo
c ]

        pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
        if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do
        (lib_errs,lib_times) <- partitionWithM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles)
        if not (null lib_errs) || any (t <) lib_times
           then return $ needsRecompileBecause LibraryChanged
           else do
            res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file
            if res
              then return $ needsRecompileBecause FlagsChanged
              else return 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
  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 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
orig_hsc_env StopPhase
stop_phase [(FilePath, Maybe Phase)]
srcs = do
  -- In oneshot mode, initialise plugins specified on command line
  -- we also initialise in ghc/Main but this might be used as an entry point by API clients who
  -- should initialise their own plugins but may not.
  -- See Note [Timing of plugin initialization]
  hsc_env <- HscEnv -> IO HscEnv
initializePlugins HscEnv
orig_hsc_env
  o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs
  case 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
   let offset_file :: FilePath
offset_file = DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
src
       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
offset_file 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
offset_file Maybe Phase
mb_phase

   exists <- FilePath -> IO Bool
doesFileExist FilePath
offset_file
   when (not exists) $
        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ offset_file))
   runPipeline (hsc_hooks hsc_env) 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
    fc :: FinderCache
fc       = HscEnv -> FinderCache
hsc_FC       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
-> TmpFs
-> FinderCache
-> DynFlags
-> UnitEnv
-> [FilePath]
-> [UnitId]
-> IO ()
linkJSBinary Logger
logger TmpFs
tmpfs FinderCache
fc 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
            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)
        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 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
      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 = 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;"
      writeFile empty_stub (showSDoc dflags (pprCode src))
      let 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 = 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
      _ <- runPipeline (hsc_hooks hsc_env) pipeline
      pure ()

    DefunctionalizedCodeOutput
_ -> do
      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 = 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;"
      writeFile empty_stub (showSDoc dflags (pprCode src))
      let 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 = 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
      _ <- runPipeline (hsc_hooks hsc_env) pipeline
      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
  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 {k} (f :: k -> *) (m :: k -> *) (a :: k).
MonadUse f m =>
f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_Unlit PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn)


  (dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn)
  let hsc_env1 = HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags1 HscEnv
hsc_env

  (cpp_fn, hsc_env2)
    <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do
          cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn)
          (dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn)
          let hsc_env2 = HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags2 HscEnv
hsc_env1
          return (cpp_fn, hsc_env2)


  pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $
            use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn)

  (dflags3, p_warns3, warns3)
    <- if pp_fn == unlit_fn
          -- Didn't run any preprocessors so don't need to reparse, would be nicer
          -- if `T_FileArgs` recognised this.
          then return (dflags1, p_warns1, warns1)
          else do
            -- Reparse with original hsc_env so that we don't get duplicated options
            use (T_FileArgs hsc_env pp_fn)

  let print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags3
  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))
  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcDriverMessage <$> warns3))
  return (dflags3, 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
  (dflags, 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' = HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
hsc_env
  (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
    <- use (T_HscRecomp pipe_env hsc_env' input_fn src_flavour)
  hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, 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
      (tc_result, warnings) <- TPhase (FrontendResult, Messages GhcMessage)
-> m (FrontendResult, Messages GhcMessage)
forall a. TPhase a -> m a
forall {k} (f :: k -> *) (m :: k -> *) (a :: k).
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 <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )
      hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum 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
      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
      -- Only run dynamic-too if the backend generates object files
      -- See Note [Writing interface files]
      -- If we are writing a simple interface (not . backendWritesFiles), then
      -- hscMaybeWriteIface in the regular pipeline will write both the hi and
      -- dyn_hi files. This way we can avoid running the pipeline twice and
      -- generating a duplicate linkable.
      -- We must not run the backend a second time with `dynamicNow` enable because
      -- all the work has already been done in the first pipeline.
      when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) ) $ do
          let dflags' = DynFlags -> DynFlags
setDynamicNow (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) -- set "dynamicNow"
          () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result
      return 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
-> ForeignStubs
-> [(ForeignSrcLang, FilePath)]
-> 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 ForeignStubs
NoStubs []) 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

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
  (fos, miface, mlinkable, o_file) <- TPhase ([FilePath], ModIface, HomeModLinkable, FilePath)
-> m ([FilePath], ModIface, HomeModLinkable, FilePath)
forall a. TPhase a -> m a
forall {k} (f :: k -> *) (m :: k -> *) (a :: k).
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)
  final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file
  final_linkable <-
    case 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
        part_time <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        final_object <- use (T_MergeForeign pipe_env hsc_env o_fp fos)
        let !linkable = UTCTime -> Module -> NonEmpty LinkablePart -> Linkable
Linkable UTCTime
part_time (ModSummary -> Module
ms_mod ModSummary
mod_sum) (LinkablePart -> NonEmpty LinkablePart
forall a. a -> NonEmpty a
NE.singleton (FilePath -> LinkableObjectSort -> LinkablePart
DotO FilePath
final_object LinkableObjectSort
ModuleObject))
        -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.
        return (mlinkable { homeMod_object = Just linkable })
  return (miface, 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 {k} (f :: k -> *) (m :: k -> *) (a :: k).
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)

lasPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)
lasPipeline :: forall (m :: * -> *).
P m =>
Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> m (Maybe FilePath)
lasPipeline 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 {k} (f :: k -> *) (m :: k -> *) (a :: k).
MonadUse f m =>
f a -> m a
use (Bool
-> PipeEnv
-> HscEnv
-> Maybe ModLocation
-> FilePath
-> TPhase FilePath
T_LlvmAs 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
  out_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall {k} (f :: k -> *) (m :: k -> *) (a :: k).
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 stop_phase 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
  opt_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall {k} (f :: k -> *) (m :: k -> *) (a :: k).
MonadUse f m =>
f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_LlvmOpt PipeEnv
pipe_env HscEnv
hsc_env FilePath
fp)
  llvmLlcPipeline pipe_env hsc_env location 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
  llc_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall {k} (f :: k -> *) (m :: k -> *) (a :: k).
MonadUse f m =>
f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_LlvmLlc PipeEnv
pipe_env HscEnv
hsc_env FilePath
opt_fn)
  llvmManglePipeline pipe_env hsc_env location 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
  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 {k} (f :: k -> *) (m :: k -> *) (a :: k).
MonadUse f m =>
f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_LlvmMangle PipeEnv
pipe_env HscEnv
hsc_env FilePath
llc_fn)
  lasPipeline False pipe_env hsc_env location mangled_fn

cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmCppPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmCppPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn = do
  output_fn <- TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall {k} (f :: k -> *) (m :: k -> *) (a :: k).
MonadUse f m =>
f a -> m a
use (PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
T_CmmCpp PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn)
  cmmPipeline pipe_env hsc_env output_fn

cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmPipeline :: forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn = do
  (fos, output_fn) <- TPhase ([FilePath], FilePath) -> m ([FilePath], FilePath)
forall a. TPhase a -> m a
forall {k} (f :: k -> *) (m :: k -> *) (a :: k).
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)
  mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn
  case mo_fn of
    Maybe FilePath
Nothing -> Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
    Just FilePath
mo_fn -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> m FilePath -> m (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TPhase FilePath -> m FilePath
forall a. TPhase a -> m a
forall {k} (f :: k -> *) (m :: k -> *) (a :: k).
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 {k} (f :: k -> *) (m :: k -> *) (a :: k).
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 {k} (f :: k -> *) (m :: k -> *) (a :: k).
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
_ (HsBootOrSig HsBootOrSig
_) 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
HsSrcFile 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
                      (_, 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 = 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
                      final_fn <- liftIO $ phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing
                      when (final_fn /= out_fn) $ do
                        let 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 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"
                        liftIO (showPass logger msg)
                        liftIO (copyWithHeader line_prag out_fn final_fn)
                      return 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 (Linkable UTCTime
_ Module
_ (DotO FilePath
lnk LinkableObjectSort
_ :| []))) = 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     = PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmCppPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn
   fromPhase Phase
Cmm        = PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
forall (m :: * -> *).
P m =>
PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
cmmPipeline PipeEnv
pipe_env HscEnv
hsc_env FilePath
input_fn
   fromPhase Phase
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.

-}