{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}

-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2011
--
-- This module implements multi-module compilation, and is used
-- by --make and GHCi.
--
-- -----------------------------------------------------------------------------
module GHC.Driver.Make (
        depanal, depanalE, depanalPartial,
        load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,

        downsweep,

        topSortModuleGraph,

        ms_home_srcimps, ms_home_imps,

        hscSourceToIsBoot,
        findExtraSigImports,
        implicitRequirementsShallow,

        noModError, cyclicModuleErr,
        SummaryNode,
        IsBootInterface(..), mkNodeKey,

        ModNodeKey, ModNodeKeyWithUid(..),
        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith,

        -- * Re-exports from Downsweep
        checkHomeUnitsClosed,
        summariseModule,
        summariseModuleInterface,
        SummariseResult(..),
        summariseFile,

        instantiationNodes,
        ) where

import GHC.Prelude
import GHC.Platform

import GHC.Tc.Utils.Backpack
import GHC.Tc.Utils.Monad  ( initIfaceCheck, concatMapM )

import GHC.Runtime.Interpreter
import qualified GHC.Linker.Loader as Linker
import GHC.Linker.Types


import GHC.Driver.Config.Diagnostic
import GHC.Driver.Pipeline
import GHC.Driver.Session
import GHC.Driver.DynFlags (ReexportedModule(..))
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Main
import GHC.Driver.MakeSem
import GHC.Driver.Downsweep
import GHC.Driver.MakeAction

import GHC.ByteCode.Types

import GHC.Iface.Load      ( cannotFindModule, readIface )
import GHC.IfaceToCore     ( typecheckIface )
import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )

import GHC.Data.Bag        ( listToBag )
import GHC.Data.Graph.Directed
import GHC.Data.Maybe      ( expectJust )

import GHC.Utils.Exception ( throwIO, SomeAsyncException )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.TmpFs

import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.PkgQual

import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModDetails

import qualified Data.Map as Map
import qualified Data.Set as Set

import Control.Concurrent.MVar
import Control.Monad
import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.Maybe
import Data.List (sortOn, groupBy, sortBy)
import System.FilePath

import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import qualified Data.Map.Strict as M
import GHC.Types.TypeEnv
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Class
import GHC.Driver.Env.KnotVars
import Control.Monad.Trans.Maybe
import GHC.Runtime.Loader
import GHC.Utils.Constants
import GHC.Iface.Errors.Types
import Data.Function
import qualified GHC.Data.Maybe as M

import GHC.Data.Graph.Directed.Reachability
import qualified GHC.Unit.Home.Graph as HUG
import GHC.Unit.Home.PackageTable

-- -----------------------------------------------------------------------------
-- Loading the program

-- | Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
--
-- Dependency analysis entails parsing the @import@ directives and may
-- therefore require running certain preprocessors.
--
-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want
-- changes to the 'DynFlags' to take effect you need to call this function
-- again.
-- In case of errors, just throw them.
--
depanal :: GhcMonad m =>
           [ModuleName]  -- ^ excluded modules
        -> Bool          -- ^ allow duplicate roots
        -> m ModuleGraph
depanal :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [ModuleName]
excluded_mods Bool
allow_dup_roots = do
    (DriverMessages
errs, ModuleGraph
mod_graph) <- (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE GhcMessage -> AnyGhcDiagnostic
forall a. (Typeable a, Diagnostic a) => a -> UnknownDiagnosticFor a
mkUnknownDiagnostic Maybe Messager
forall a. Maybe a
Nothing [ModuleName]
excluded_mods Bool
allow_dup_roots
    if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
      then ModuleGraph -> m ModuleGraph
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
      else Messages GhcMessage -> m ModuleGraph
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors ((DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage DriverMessages
errs)

-- | Perform dependency analysis like in 'depanal'.
-- In case of errors, the errors and an empty module graph are returned.
depanalE :: GhcMonad m =>     -- New for #17459
               (GhcMessage -> AnyGhcDiagnostic)
            -> Maybe Messager
            -> [ModuleName]      -- ^ excluded modules
            -> Bool           -- ^ allow duplicate roots
            -> m (DriverMessages, ModuleGraph)
depanalE :: forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [ModuleName]
excluded_mods Bool
allow_dup_roots = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    (DriverMessages
errs, ModuleGraph
mod_graph) <- (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalPartial GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [ModuleName]
excluded_mods Bool
allow_dup_roots
    if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
      then do
        HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
        let one_unit_messages :: IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages
one_unit_messages IO DriverMessages
get_mod_errs UnitId
k HomeUnitEnv
hue = do
              DriverMessages
errs <- IO DriverMessages
get_mod_errs
              DriverMessages
unknown_module_err <- HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
k HscEnv
hsc_env) (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) ModuleGraph
mod_graph

              let unused_home_mod_err :: DriverMessages
unused_home_mod_err = DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env) ModuleGraph
mod_graph
                  unused_pkg_err :: DriverMessages
unused_pkg_err = UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue) (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) ModuleGraph
mod_graph


              return $ DriverMessages
errs DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_home_mod_err
                          DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_pkg_err
                          DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unknown_module_err

        DriverMessages
all_errs <- IO DriverMessages -> m DriverMessages
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DriverMessages -> m DriverMessages)
-> IO DriverMessages -> m DriverMessages
forall a b. (a -> b) -> a -> b
$ (IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages)
-> IO DriverMessages
-> UnitEnvGraph HomeUnitEnv
-> IO DriverMessages
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
HUG.unitEnv_foldWithKey IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages
one_unit_messages (DriverMessages -> IO DriverMessages
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DriverMessages
forall e. Messages e
emptyMessages) (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env)
        Messages GhcMessage -> m ()
forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DriverMessages
all_errs)
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph = mod_graph }
        pure (DriverMessages
forall e. Messages e
emptyMessages, ModuleGraph
mod_graph)
      else do
        -- We don't have a complete module dependency graph,
        -- The graph may be disconnected and is unusable.
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph = emptyMG }
        pure (DriverMessages
errs, ModuleGraph
emptyMG)


-- | Perform dependency analysis like 'depanal' but return a partial module
-- graph even in the face of problems with some modules.
--
-- Modules which have parse errors in the module header, failing
-- preprocessors or other issues preventing them from being summarised will
-- simply be absent from the returned module graph.
--
-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the
-- new module graph.
depanalPartial
    :: GhcMonad m
    => (GhcMessage -> AnyGhcDiagnostic)
    -> Maybe Messager
    -> [ModuleName]  -- ^ excluded modules
    -> Bool          -- ^ allow duplicate roots
    -> m (DriverMessages, ModuleGraph)
    -- ^ possibly empty 'Bag' of errors and a module graph.
depanalPartial :: forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalPartial GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [ModuleName]
excluded_mods Bool
allow_dup_roots = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let
         targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
         old_graph :: ModuleGraph
old_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
         logger :: Logger
logger  = HscEnv -> Logger
hsc_logger HscEnv
hsc_env

  Logger
-> SDoc
-> ((DriverMessages, ModuleGraph) -> ())
-> m (DriverMessages, ModuleGraph)
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Chasing dependencies") (() -> (DriverMessages, ModuleGraph) -> ()
forall a b. a -> b -> a
const ()) (m (DriverMessages, ModuleGraph)
 -> m (DriverMessages, ModuleGraph))
-> m (DriverMessages, ModuleGraph)
-> m (DriverMessages, ModuleGraph)
forall a b. (a -> b) -> a -> b
$ do
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Chasing modules from: ",
              [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ((Target -> SDoc) -> [Target] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Target -> SDoc
pprTarget [Target]
targets))])

    -- Home package modules may have been moved or deleted, and new
    -- source files may have appeared in the home package that shadow
    -- external package modules, so we have to discard the existing
    -- cached finder data.
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FinderCache -> UnitEnv -> IO ()
flushFinderCaches (HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env) (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)

    ([DriverMessages]
errs, ModuleGraph
mod_graph) <- IO ([DriverMessages], ModuleGraph)
-> m ([DriverMessages], ModuleGraph)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([DriverMessages], ModuleGraph)
 -> m ([DriverMessages], ModuleGraph))
-> IO ([DriverMessages], ModuleGraph)
-> m ([DriverMessages], ModuleGraph)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], ModuleGraph)
downsweep
      HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
old_graph)
      [ModuleName]
excluded_mods Bool
allow_dup_roots
    return ([DriverMessages] -> DriverMessages
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages [DriverMessages]
errs, ModuleGraph
mod_graph)


-- Note [Missing home modules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Sometimes we don't want GHC to process modules that weren't specified as
-- explicit targets. For example, cabal may want to enable this warning
-- when building a library, so that GHC warns the user about modules listed
-- neither in `exposed-modules` nor in `other-modules`.
--
-- Here "home module" means a module that doesn't come from another package.
--
-- For example, if GHC is invoked with modules "A" and "B" as targets,
-- but "A" imports some other module "C", then GHC will issue a warning
-- about module "C" not being listed in the command line.
--
-- The warning in enabled by `-Wmissing-home-modules`. See #13129
warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules DynFlags
dflags [Target]
targets ModuleGraph
mod_graph =
    if [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing
      then DriverMessages
forall e. Messages e
emptyMessages
      else DriverMessages
warn
  where
    diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags

    -- We need to be careful to handle the case where (possibly
    -- path-qualified) filenames (aka 'TargetFile') rather than module
    -- names are being passed on the GHC command-line.
    --
    -- For instance, `ghc --make src-exe/Main.hs` and
    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.
    -- Note also that we can't always infer the associated module name
    -- directly from the filename argument.  See #13727.
    is_known_module :: ModSummary -> Bool
is_known_module ModSummary
mod =
      ModSummary -> Bool
is_module_target ModSummary
mod
      Bool -> Bool -> Bool
||
      Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False String -> Bool
is_file_target (ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod))

    is_module_target :: ModSummary -> Bool
is_module_target ModSummary
mod = (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod), ModSummary -> UnitId
ms_unitid ModSummary
mod) (ModuleName, UnitId) -> Set (ModuleName, UnitId) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (ModuleName, UnitId)
mod_targets

    is_file_target :: String -> Bool
is_file_target String
file = String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (String -> String
withoutExt String
file) Set String
file_targets

    file_targets :: Set String
file_targets = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ((Target -> Maybe String) -> [Target] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Target -> Maybe String
file_target [Target]
targets)

    file_target :: Target -> Maybe String
file_target Target {TargetId
targetId :: TargetId
targetId :: Target -> TargetId
targetId} =
      case TargetId
targetId of
        TargetModule ModuleName
_ -> Maybe String
forall a. Maybe a
Nothing
        TargetFile String
file Maybe Phase
_ ->
          String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
withoutExt (DynFlags -> String -> String
augmentByWorkingDirectory DynFlags
dflags String
file))

    mod_targets :: Set (ModuleName, UnitId)
mod_targets = [(ModuleName, UnitId)] -> Set (ModuleName, UnitId)
forall a. Ord a => [a] -> Set a
Set.fromList (Target -> (ModuleName, UnitId)
mod_target (Target -> (ModuleName, UnitId))
-> [Target] -> [(ModuleName, UnitId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Target]
targets)

    mod_target :: Target -> (ModuleName, UnitId)
mod_target Target {UnitId
targetUnitId :: UnitId
targetUnitId :: Target -> UnitId
targetUnitId, TargetId
targetId :: Target -> TargetId
targetId :: TargetId
targetId} =
      case TargetId
targetId of
        TargetModule ModuleName
name -> (ModuleName
name, UnitId
targetUnitId)
        TargetFile String
file Maybe Phase
_ -> (String -> ModuleName
mkModuleName (String -> String
withoutExt String
file), UnitId
targetUnitId)

    withoutExt :: String -> String
withoutExt = (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (String -> (String, String)) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
splitExtension

    missing :: [ModuleName]
missing = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) ([ModSummary] -> [ModuleName]) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
      (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModSummary -> Bool) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
is_known_module) ([ModSummary] -> [ModSummary]) -> [ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$
        ((ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> ModSummary -> UnitId
ms_unitid ModSummary
ms UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
                (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph))

    warn :: DriverMessages
warn = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
                         (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ UnitId -> [ModuleName] -> BuildingCabalPackage -> DriverMessage
DriverMissingHomeModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) [ModuleName]
missing (DynFlags -> BuildingCabalPackage
checkBuildingCabalPackage DynFlags
dflags)

-- Check that any modules we want to reexport or hide are actually in the package.
warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules HscEnv
hsc_env DynFlags
dflags ModuleGraph
mod_graph = do
  [ReexportedModule]
reexported_warns <- (ReexportedModule -> IO Bool)
-> [ReexportedModule] -> IO [ReexportedModule]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ReexportedModule -> IO Bool
check_reexport [ReexportedModule]
reexported_mods
  return $ Set ModuleName -> [ReexportedModule] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ReexportedModule]
reexported_warns
  where
    diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags

    unit_mods :: Set ModuleName
unit_mods = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name
                  ((ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> ModSummary -> UnitId
ms_unitid ModSummary
ms UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
                       (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)))

    reexported_mods :: [ReexportedModule]
reexported_mods = DynFlags -> [ReexportedModule]
reexportedModules DynFlags
dflags
    hidden_mods :: Set ModuleName
hidden_mods     = DynFlags -> Set ModuleName
hiddenModules DynFlags
dflags

    hidden_warns :: Set ModuleName
hidden_warns = Set ModuleName
hidden_mods Set ModuleName -> Set ModuleName -> Set ModuleName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ModuleName
unit_mods

    lookupModule :: ModuleName -> IO FindResult
lookupModule ModuleName
mn = HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mn PkgQual
NoPkgQual

    check_reexport :: ReexportedModule -> IO Bool
check_reexport ReexportedModule
mn = do
      FindResult
fr <- ModuleName -> IO FindResult
lookupModule (ReexportedModule -> ModuleName
reexportFrom ReexportedModule
mn)
      case FindResult
fr of
        Found ModLocation
_ Module
m -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> UnitId
moduleUnitId Module
m UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
        FindResult
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


    warn :: DriverMessage -> DriverMessages
warn DriverMessage
diagnostic = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
                         (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage
diagnostic

    final_msgs :: Set ModuleName -> [ReexportedModule] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ReexportedModule]
reexported_warns
          =
        [DriverMessages] -> DriverMessages
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages ([DriverMessages] -> DriverMessages)
-> [DriverMessages] -> DriverMessages
forall a b. (a -> b) -> a -> b
$
          [DriverMessage -> DriverMessages
warn (UnitId -> [ModuleName] -> DriverMessage
DriverUnknownHiddenModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
hidden_warns)) | Bool -> Bool
not (Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null Set ModuleName
hidden_warns)]
          [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessage -> DriverMessages
warn (UnitId -> [ReexportedModule] -> DriverMessage
DriverUnknownReexportedModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) [ReexportedModule]
reexported_warns) | Bool -> Bool
not ([ReexportedModule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ReexportedModule]
reexported_warns)]

-- | Describes which modules of the module graph need to be loaded.
data LoadHowMuch
   = LoadAllTargets
     -- ^ Load all targets and its dependencies.
   | LoadUpTo HomeUnitModule
     -- ^ Load only the given module and its dependencies.
   | LoadDependenciesOf HomeUnitModule
     -- ^ Load only the dependencies of the given module, but not the module
     -- itself.

{-
Note [Caching HomeModInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~

API clients who call `load` like to cache the HomeModInfo in memory between
calls to this function. In the old days, this cache was a simple MVar which stored
a HomePackageTable. This was insufficient, as the interface files for boot modules
were not recorded in the cache. In the less old days, the cache was returned at the
end of load, and supplied at the start of load, however, this was not sufficient
because it didn't account for the possibility of exceptions such as SIGINT (#20780).

So now, in the current day, we have this ModIfaceCache abstraction which
can incrementally be updated during the process of upsweep. This allows us
to store interface files for boot modules in an exception-safe way.

When the final version of an interface file is completed then it is placed into
the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache.

Note that because we only store the ModIface and Linkable in the ModIfaceCache,
hydration and rehydration is totally irrelevant, and we just store the CachedIface as
soon as it is completed.

-}


-- Abstract interface to a cache of HomeModInfo
-- See Note [Caching HomeModInfo]
data ModIfaceCache = ModIfaceCache { ModIfaceCache -> IO [CachedIface]
iface_clearCache :: IO [CachedIface]
                                   , ModIfaceCache -> CachedIface -> IO ()
iface_addToCache :: CachedIface -> IO () }

addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache ModIfaceCache
c (HomeModInfo ModIface
i ModDetails
_ HomeModLinkable
l) = ModIfaceCache -> CachedIface -> IO ()
iface_addToCache ModIfaceCache
c (ModIface -> HomeModLinkable -> CachedIface
CachedIface ModIface
i HomeModLinkable
l)

data CachedIface = CachedIface { CachedIface -> ModIface
cached_modiface :: !ModIface
                               , CachedIface -> HomeModLinkable
cached_linkable :: !HomeModLinkable }

instance Outputable CachedIface where
  ppr :: CachedIface -> SDoc
ppr (CachedIface ModIface
mi HomeModLinkable
ln) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CachedIface", ModNodeKeyWithUid -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> ModNodeKeyWithUid
miKey ModIface
mi), HomeModLinkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr HomeModLinkable
ln]

noIfaceCache :: Maybe ModIfaceCache
noIfaceCache :: Maybe ModIfaceCache
noIfaceCache = Maybe ModIfaceCache
forall a. Maybe a
Nothing

newIfaceCache :: IO ModIfaceCache
newIfaceCache :: IO ModIfaceCache
newIfaceCache = do
  IORef [CachedIface]
ioref <- [CachedIface] -> IO (IORef [CachedIface])
forall a. a -> IO (IORef a)
newIORef []
  return $
    ModIfaceCache
      { iface_clearCache :: IO [CachedIface]
iface_clearCache = IORef [CachedIface]
-> ([CachedIface] -> ([CachedIface], [CachedIface]))
-> IO [CachedIface]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [CachedIface]
ioref (\[CachedIface]
c -> ([], [CachedIface]
c))
      , iface_addToCache :: CachedIface -> IO ()
iface_addToCache = \CachedIface
hmi -> IORef [CachedIface]
-> ([CachedIface] -> ([CachedIface], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [CachedIface]
ioref (\[CachedIface]
c -> (CachedIface
hmiCachedIface -> [CachedIface] -> [CachedIface]
forall a. a -> [a] -> [a]
:[CachedIface]
c, ()))
      }




-- | Try to load the program.  See 'LoadHowMuch' for the different modes.
--
-- This function implements the core of GHC's @--make@ mode.  It preprocesses,
-- compiles and loads the specified modules, avoiding re-compilation wherever
-- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling
-- and loading may result in files being created on disk.
--
-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
-- successful or not.
--
-- If errors are encountered during dependency analysis, the module `depanalE`
-- returns together with the errors an empty ModuleGraph.
-- After processing this empty ModuleGraph, the errors of depanalE are thrown.
-- All other errors are reported using the 'defaultWarnErrLogger'.

load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
load :: forall (f :: * -> *). GhcMonad f => LoadHowMuch -> f SuccessFlag
load LoadHowMuch
how_much = Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic) -> LoadHowMuch -> f SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic) -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
noIfaceCache GhcMessage -> AnyGhcDiagnostic
forall a. (Typeable a, Diagnostic a) => a -> UnknownDiagnosticFor a
mkUnknownDiagnostic LoadHowMuch
how_much

mkBatchMsg :: HscEnv -> Messager
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg HscEnv
hsc_env =
  if Set UnitId -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
    -- This also displays what unit each module is from.
    then Messager
batchMultiMsg
    else Messager
batchMsg


loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them.
                            -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user.
                                                                -- If you are using the GHC API you can use this to override how messages
                                                                -- created during 'loadWithCache' are displayed to the user.
                            -> LoadHowMuch -- ^ How much `loadWithCache` should load
                            -> m SuccessFlag
loadWithCache :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic) -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
cache GhcMessage -> AnyGhcDiagnostic
diag_wrapper LoadHowMuch
how_much = do
    Messager
msg <- HscEnv -> Messager
mkBatchMsg (HscEnv -> Messager) -> m HscEnv -> m Messager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    (DriverMessages
errs, ModuleGraph
mod_graph) <- (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE GhcMessage -> AnyGhcDiagnostic
diag_wrapper (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
msg) [] Bool
False                        -- #17459
    SuccessFlag
success <- Maybe ModIfaceCache
-> LoadHowMuch
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> ModuleGraph
-> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> ModuleGraph
-> m SuccessFlag
load' Maybe ModIfaceCache
cache LoadHowMuch
how_much GhcMessage -> AnyGhcDiagnostic
diag_wrapper (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
    if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
      then SuccessFlag -> m SuccessFlag
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
      else Messages GhcMessage -> m SuccessFlag
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors ((DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage DriverMessages
errs)

-- Note [Unused packages]
-- ~~~~~~~~~~~~~~~~~~~~~~
-- Cabal passes `-package-id` flag for each direct dependency. But GHC
-- loads them lazily, so when compilation is done, we have a list of all
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.

warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages UnitState
us DynFlags
dflags ModuleGraph
mod_graph =
    let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags

        home_mod_sum :: [ModSummary]
home_mod_sum = (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> DynFlags -> UnitId
homeUnitId_ DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> UnitId
ms_unitid ModSummary
ms) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)

    -- Only need non-source imports here because SOURCE imports are always HPT
        loadedPackages :: [UnitInfo]
loadedPackages = [[UnitInfo]] -> [UnitInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[UnitInfo]] -> [UnitInfo]) -> [[UnitInfo]] -> [UnitInfo]
forall a b. (a -> b) -> a -> b
$
          ((ImportLevel, PkgQual, GenLocated SrcSpan ModuleName)
 -> Maybe [UnitInfo])
-> [(ImportLevel, PkgQual, GenLocated SrcSpan ModuleName)]
-> [[UnitInfo]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(ImportLevel
_st, PkgQual
fs, GenLocated SrcSpan ModuleName
mn) -> UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage UnitState
us (GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
mn) PkgQual
fs)
            ([(ImportLevel, PkgQual, GenLocated SrcSpan ModuleName)]
 -> [[UnitInfo]])
-> [(ImportLevel, PkgQual, GenLocated SrcSpan ModuleName)]
-> [[UnitInfo]]
forall a b. (a -> b) -> a -> b
$ (ModSummary
 -> [(ImportLevel, PkgQual, GenLocated SrcSpan ModuleName)])
-> [ModSummary]
-> [(ImportLevel, PkgQual, GenLocated SrcSpan ModuleName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary
-> [(ImportLevel, PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps [ModSummary]
home_mod_sum

        used_args :: Set UnitId
used_args = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
loadedPackages)

        resolve :: (Unit, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg)
resolve (Unit
u,Maybe PackageArg
mflag) = do
                  -- The units which we depend on via the command line explicitly
                  PackageArg
flag <- Maybe PackageArg
mflag
                  -- Which we can find the UnitInfo for (should be all of them)
                  UnitInfo
ui <- UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
us Unit
u
                  -- Which are not explicitly used
                  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui) Set UnitId
used_args)
                  return (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui, UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
ui, UnitInfo -> Version
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
unitPackageVersion UnitInfo
ui, PackageArg
flag)

        unusedArgs :: [(UnitId, PackageName, Version, PackageArg)]
unusedArgs = ((UnitId, PackageName, Version, PackageArg) -> UnitId)
-> [(UnitId, PackageName, Version, PackageArg)]
-> [(UnitId, PackageName, Version, PackageArg)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(UnitId
u,PackageName
_,Version
_,PackageArg
_) -> UnitId
u) ([(UnitId, PackageName, Version, PackageArg)]
 -> [(UnitId, PackageName, Version, PackageArg)])
-> [(UnitId, PackageName, Version, PackageArg)]
-> [(UnitId, PackageName, Version, PackageArg)]
forall a b. (a -> b) -> a -> b
$ ((Unit, Maybe PackageArg)
 -> Maybe (UnitId, PackageName, Version, PackageArg))
-> [(Unit, Maybe PackageArg)]
-> [(UnitId, PackageName, Version, PackageArg)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Unit, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg)
resolve (UnitState -> [(Unit, Maybe PackageArg)]
explicitUnits UnitState
us)

        warn :: DriverMessages
warn = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan ([(UnitId, PackageName, Version, PackageArg)] -> DriverMessage
DriverUnusedPackages [(UnitId, PackageName, Version, PackageArg)]
unusedArgs)

    in if [(UnitId, PackageName, Version, PackageArg)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitId, PackageName, Version, PackageArg)]
unusedArgs
        then DriverMessages
forall e. Messages e
emptyMessages
        else DriverMessages
warn

-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any
-- path from module to its boot file.
data ModuleGraphNodeWithBootFile
  = ModuleGraphNodeWithBootFile
     ModuleGraphNode
       -- ^ The module itself (not the hs-boot module)
     [NodeKey]
       -- ^ The modules in between the module and its hs-boot file,
       -- not including the hs-boot file itself.


instance Outputable ModuleGraphNodeWithBootFile where
  ppr :: ModuleGraphNodeWithBootFile -> SDoc
ppr (ModuleGraphNodeWithBootFile ModuleGraphNode
mgn [NodeKey]
deps) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ModeGraphNodeWithBootFile: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleGraphNode -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [NodeKey] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [NodeKey]
deps

-- | A 'BuildPlan' is the result of attempting to linearise a single strongly-connected
-- component of the module graph.
data BuildPlan
  -- | A simple, single module all alone (which *might* have an hs-boot file, if it isn't part of a cycle)
  = SingleModule ModuleGraphNode
  -- | A resolved cycle, linearised by hs-boot files
  | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
  -- | An actual cycle, which wasn't resolved by hs-boot files
  | UnresolvedCycle [ModuleGraphNode]

instance Outputable BuildPlan where
  ppr :: BuildPlan -> SDoc
ppr (SingleModule ModuleGraphNode
mgn) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SingleModule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (ModuleGraphNode -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn)
  ppr (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn)   = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ResolvedCycle:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn
  ppr (UnresolvedCycle [ModuleGraphNode]
mgn) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UnresolvedCycle:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ModuleGraphNode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mgn


-- Just used for an assertion
countMods :: BuildPlan -> Int
countMods :: BuildPlan -> Int
countMods (SingleModule ModuleGraphNode
_) = Int
1
countMods (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns) = [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns
countMods (UnresolvedCycle [ModuleGraphNode]
ns) = [ModuleGraphNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleGraphNode]
ns

-- See Note [Upsweep] for a high-level description.
createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod =
    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles
        cycle_mod_graph :: [SCC ModuleGraphNode]
cycle_mod_graph = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod

        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.
        build_plan :: [BuildPlan]
        build_plan :: [BuildPlan]
build_plan
          -- Fast path, if there are no boot modules just do a normal toposort
          | ModuleEnv (ModuleGraphNode, [ModuleGraphNode]) -> Bool
forall a. ModuleEnv a -> Bool
isEmptyModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([SCC ModuleGraphNode] -> [BuildPlan])
-> [SCC ModuleGraphNode] -> [BuildPlan]
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod
          | Bool
otherwise = [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
cycle_mod_graph []

        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [] [ModuleGraphNode]
mgn = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
mgn)
        toBuildPlan ((AcyclicSCC ModuleGraphNode
node):[SCC ModuleGraphNode]
sccs) [ModuleGraphNode]
mgn = [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
sccs (ModuleGraphNode
nodeModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. a -> [a] -> [a]
:[ModuleGraphNode]
mgn)
        -- Interesting case
        toBuildPlan ((CyclicSCC [ModuleGraphNode]
nodes):[SCC ModuleGraphNode]
sccs) [ModuleGraphNode]
mgn =
          let acyclic :: [BuildPlan]
acyclic = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
mgn)
              -- Now perform another toposort but just with these nodes and relevant hs-boot files.
              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.
              mresolved_cycle :: Either
  [ModuleGraphNode]
  [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle = [SCC ModuleGraphNode]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
nodes)
          in [BuildPlan]
acyclic [BuildPlan] -> [BuildPlan] -> [BuildPlan]
forall a. [a] -> [a] -> [a]
++ [([ModuleGraphNode] -> BuildPlan)
-> ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
    -> BuildPlan)
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildPlan
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [ModuleGraphNode] -> BuildPlan
UnresolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildPlan
ResolvedCycle Either
  [ModuleGraphNode]
  [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle] [BuildPlan] -> [BuildPlan] -> [BuildPlan]
forall a. [a] -> [a] -> [a]
++ [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
sccs []

        -- Compute the intermediate modules between a file and its hs-boot file.
        -- See Step 2a in Note [Upsweep]
        boot_path :: ModuleName -> UnitId -> [ModuleGraphNode]
boot_path ModuleName
mn UnitId
uid =
          Set ModuleGraphNode -> [ModuleGraphNode]
forall a. Set a -> [a]
Set.toList (Set ModuleGraphNode -> [ModuleGraphNode])
-> Set ModuleGraphNode -> [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$
          -- Don't include the boot module itself
          (ModuleGraphNode -> Bool)
-> Set ModuleGraphNode -> Set ModuleGraphNode
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((NodeKey -> NodeKey -> Bool
forall a. Eq a => a -> a -> Bool
/= ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot)) (NodeKey -> Bool)
-> (ModuleGraphNode -> NodeKey) -> ModuleGraphNode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> NodeKey
mkNodeKey)  (Set ModuleGraphNode -> Set ModuleGraphNode)
-> Set ModuleGraphNode -> Set ModuleGraphNode
forall a b. (a -> b) -> a -> b
$
          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are
          -- the transitive dependencies of the non-boot file which transitively depend
          -- on the boot file.
          (ModuleGraphNode -> Bool)
-> Set ModuleGraphNode -> Set ModuleGraphNode
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(ModuleGraphNode -> NodeKey
mkNodeKey -> NodeKey
nk) ->
            NodeKey -> UnitId
nodeKeyUnitId NodeKey
nk UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
uid  -- Cheap test
              Bool -> Bool -> Bool
&& ModuleGraph -> NodeKey -> NodeKey -> Bool
mgQuery ModuleGraph
mod_graph NodeKey
nk (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot))) (Set ModuleGraphNode -> Set ModuleGraphNode)
-> Set ModuleGraphNode -> Set ModuleGraphNode
forall a b. (a -> b) -> a -> b
$
          [ModuleGraphNode] -> Set ModuleGraphNode
forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleGraphNode] -> Set ModuleGraphNode)
-> [ModuleGraphNode] -> Set ModuleGraphNode
forall a b. (a -> b) -> a -> b
$
          Maybe [ModuleGraphNode] -> [ModuleGraphNode]
forall a. HasCallStack => Maybe a -> a
expectJust (ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode]
mgReachable ModuleGraph
mod_graph (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
NotBoot)))
          where
            key :: IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
ib = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
ib) UnitId
uid


        -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists
        boot_modules :: ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = [(Module, (ModuleGraphNode, [ModuleGraphNode]))]
-> ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv
          [ (Module
mn, (ModuleGraphNode
m, ModuleName -> UnitId -> [ModuleGraphNode]
boot_path (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mn) (Module -> UnitId
moduleUnitId Module
mn)))
            | m :: ModuleGraphNode
m@(ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
ms) <- ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph
            , let mn :: Module
mn = ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
ms
            , ModuleNodeInfo -> IsBootInterface
isBootModuleNodeInfo ModuleNodeInfo
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]

        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules = (ModuleGraphNode -> Maybe ModuleGraphNode)
-> [ModuleGraphNode] -> [ModuleGraphNode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((ModuleGraphNode, [ModuleGraphNode]) -> ModuleGraphNode)
-> Maybe (ModuleGraphNode, [ModuleGraphNode])
-> Maybe ModuleGraphNode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleGraphNode, [ModuleGraphNode]) -> ModuleGraphNode
forall a b. (a, b) -> a
fst (Maybe (ModuleGraphNode, [ModuleGraphNode])
 -> Maybe ModuleGraphNode)
-> (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))
-> ModuleGraphNode
-> Maybe ModuleGraphNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module)

        get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
        get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module (ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
ms)
          | IsBootInterface
NotBoot <- ModuleNodeInfo -> IsBootInterface
isBootModuleNodeInfo ModuleNodeInfo
ms
          = ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
-> Module -> Maybe (ModuleGraphNode, [ModuleGraphNode])
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules (ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
ms)
        get_boot_module ModuleGraphNode
_ = Maybe (ModuleGraphNode, [ModuleGraphNode])
forall a. Maybe a
Nothing

        -- Any cycles should be resolved now
        collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
        -- Must be at least two nodes, as we were in a cycle
        collapseSCC :: [SCC ModuleGraphNode]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [AcyclicSCC ModuleGraphNode
node1, AcyclicSCC ModuleGraphNode
node2] = [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a b. b -> Either a b
Right [ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node1, ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node2]
        collapseSCC (AcyclicSCC ModuleGraphNode
node : [SCC ModuleGraphNode]
nodes) = ([ModuleGraphNode]
 -> Either
      [ModuleGraphNode]
      [Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
    -> Either
         [ModuleGraphNode]
         [Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([ModuleGraphNode]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a b. a -> Either a b
Left ([ModuleGraphNode]
 -> Either
      [ModuleGraphNode]
      [Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> ([ModuleGraphNode] -> [ModuleGraphNode])
-> [ModuleGraphNode]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleGraphNode
node ModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. a -> [a] -> [a]
:)) ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a b. b -> Either a b
Right ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
 -> Either
      [ModuleGraphNode]
      [Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
    -> [Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a. a -> [a] -> [a]
:)) ([SCC ModuleGraphNode]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [SCC ModuleGraphNode]
nodes)
        -- Cyclic
        collapseSCC [SCC ModuleGraphNode]
nodes = [ModuleGraphNode]
-> Either
     [ModuleGraphNode]
     [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a b. a -> Either a b
Left ([SCC ModuleGraphNode] -> [ModuleGraphNode]
forall a. [SCC a] -> [a]
flattenSCCs [SCC ModuleGraphNode]
nodes)

        toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile
        toNodeWithBoot :: ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
mn =
          case ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module ModuleGraphNode
mn of
            -- The node doesn't have a boot file
            Maybe (ModuleGraphNode, [ModuleGraphNode])
Nothing -> ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
forall a b. a -> Either a b
Left ModuleGraphNode
mn
            -- The node does have a boot file
            Just (ModuleGraphNode, [ModuleGraphNode])
path -> ModuleGraphNodeWithBootFile
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
forall a b. b -> Either a b
Right (ModuleGraphNode -> [NodeKey] -> ModuleGraphNodeWithBootFile
ModuleGraphNodeWithBootFile ModuleGraphNode
mn ((ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey ((ModuleGraphNode, [ModuleGraphNode]) -> [ModuleGraphNode]
forall a b. (a, b) -> b
snd (ModuleGraphNode, [ModuleGraphNode])
path)))

        -- The toposort and accumulation of acyclic modules is solely to pick-up
        -- hs-boot files which are **not** part of cycles.
        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic (AcyclicSCC ModuleGraphNode
node : [SCC ModuleGraphNode]
nodes) = ModuleGraphNode -> BuildPlan
SingleModule ModuleGraphNode
node BuildPlan -> [BuildPlan] -> [BuildPlan]
forall a. a -> [a] -> [a]
: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic [SCC ModuleGraphNode]
nodes
        collapseAcyclic (CyclicSCC [ModuleGraphNode]
cy_nodes : [SCC ModuleGraphNode]
nodes) = ([ModuleGraphNode] -> BuildPlan
UnresolvedCycle [ModuleGraphNode]
cy_nodes) BuildPlan -> [BuildPlan] -> [BuildPlan]
forall a. a -> [a] -> [a]
: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic [SCC ModuleGraphNode]
nodes
        collapseAcyclic [] = []

        topSortWithBoot :: [ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
nodes = Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
False ([ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules [ModuleGraphNode]
nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
nodes) Maybe HomeUnitModule
forall a. Maybe a
Nothing


  in

    Bool -> SDoc -> [BuildPlan] -> [BuildPlan]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleGraph -> Int
lengthMG ModuleGraph
mod_graph)
              ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Build plan missing nodes:", (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"PLAN:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan))), (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"GRAPH:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleGraph -> Int
lengthMG ModuleGraph
mod_graph))])
              [BuildPlan]
build_plan


-- | Generalized version of 'load' which also supports a custom
-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
-- produced by calling 'depanal'.
load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> ModuleGraph
-> m SuccessFlag
load' Maybe ModIfaceCache
mhmi_cache LoadHowMuch
how_much GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
    -- In normal usage plugins are initialised already by ghc/Main.hs this is protective
    -- for any client who might interact with GHC via load'.
    -- See Note [Timing of plugin initialization]
    m ()
forall (m :: * -> *). GhcMonad m => m ()
initializeSessionPlugins
    (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph = mod_graph }
    m ()
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env

    -- The "bad" boot modules are the ones for which we have
    -- B.hs-boot in the module graph, but no B.hs
    -- The downsweep should have ensured this does not happen
    -- (see msDeps)
    let all_home_mods :: Set HomeUnitModule
all_home_mods =
          [HomeUnitModule] -> Set HomeUnitModule
forall a. Ord a => [a] -> Set a
Set.fromList [ UnitId -> ModuleName -> HomeUnitModule
forall unit. unit -> ModuleName -> GenModule unit
Module (ModSummary -> UnitId
ms_unitid ModSummary
s) (ModSummary -> ModuleName
ms_mod_name ModSummary
s)
                    | ModSummary
s <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
s IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot]
    -- TODO: Figure out what the correct form of this assert is. It's violated
    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
    -- files without corresponding hs files.
    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
    --                              not (ms_mod_name s `elem` all_home_mods)]
    -- assert (null bad_boot_mods ) return ()

    -- check that the module given in HowMuch actually exists, otherwise
    -- topSortModuleGraph will bomb later.
    let checkHowMuch :: LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch (LoadUpTo HomeUnitModule
m)           = HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m
        checkHowMuch (LoadDependenciesOf HomeUnitModule
m) = HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m
        checkHowMuch LoadHowMuch
_ = m SuccessFlag -> m SuccessFlag
forall a. a -> a
id

        checkMod :: HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m m SuccessFlag
and_then
            | HomeUnitModule
m HomeUnitModule -> Set HomeUnitModule -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HomeUnitModule
all_home_mods = m SuccessFlag
and_then
            | Bool
otherwise = do
                    MsgEnvelope GhcMessage -> m SuccessFlag
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> m SuccessFlag)
-> MsgEnvelope GhcMessage -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan
                                  (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage
                                  (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ UnitId -> ModuleName -> DriverMessage
DriverModuleNotFound (HomeUnitModule -> UnitId
forall unit. GenModule unit -> unit
moduleUnit HomeUnitModule
m) (HomeUnitModule -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName HomeUnitModule
m)

    LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch LoadHowMuch
how_much (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ do

    -- mg2_with_srcimps drops the hi-boot nodes, returning a
    -- graph with cycles. It is just used for warning about unnecessary source imports.
    let mg2_with_srcimps :: [SCC ModuleGraphNode]
        mg2_with_srcimps :: [SCC ModuleGraphNode]
mg2_with_srcimps = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph Maybe HomeUnitModule
forall a. Maybe a
Nothing

    -- If we can determine that any of the {-# SOURCE #-} imports
    -- are definitely unnecessary, then emit a warning.
    [SCC ModuleNodeInfo] -> m ()
forall (m :: * -> *). GhcMonad m => [SCC ModuleNodeInfo] -> m ()
warnUnnecessarySourceImports ([SCC ModuleGraphNode] -> [SCC ModuleNodeInfo]
filterToposortToModules [SCC ModuleGraphNode]
mg2_with_srcimps)

    let maybe_top_mod :: Maybe HomeUnitModule
maybe_top_mod = case LoadHowMuch
how_much of
                          LoadUpTo HomeUnitModule
m           -> HomeUnitModule -> Maybe HomeUnitModule
forall a. a -> Maybe a
Just HomeUnitModule
m
                          LoadDependenciesOf HomeUnitModule
m -> HomeUnitModule -> Maybe HomeUnitModule
forall a. a -> Maybe a
Just HomeUnitModule
m
                          LoadHowMuch
_                    -> Maybe HomeUnitModule
forall a. Maybe a
Nothing

        build_plan :: [BuildPlan]
build_plan = ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod


    [CachedIface]
cache <- IO [CachedIface] -> m [CachedIface]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CachedIface] -> m [CachedIface])
-> IO [CachedIface] -> m [CachedIface]
forall a b. (a -> b) -> a -> b
$ IO [CachedIface]
-> (ModIfaceCache -> IO [CachedIface])
-> Maybe ModIfaceCache
-> IO [CachedIface]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([CachedIface] -> IO [CachedIface]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) ModIfaceCache -> IO [CachedIface]
iface_clearCache Maybe ModIfaceCache
mhmi_cache
    let
        -- prune the HPT so everything is not retained when doing an
        -- upsweep.
        !pruned_cache :: [HomeModInfo]
pruned_cache = [CachedIface] -> [ModSummary] -> [HomeModInfo]
pruneCache [CachedIface]
cache
                            [ModSummary
ms | (ModuleNodeCompile ModSummary
ms) <- ([SCC ModuleNodeInfo] -> [ModuleNodeInfo]
forall a. [SCC a] -> [a]
flattenSCCs ([SCC ModuleGraphNode] -> [SCC ModuleNodeInfo]
filterToposortToModules  [SCC ModuleGraphNode]
mg2_with_srcimps))]



    -- before we unload anything, make sure we don't leave an old
    -- interactive context around pointing to dead bindings.  Also,
    -- write an empty HPT to allow the old HPT to be GC'd.

    let pruneHomeUnitEnv :: HomeUnitEnv -> m HomeUnitEnv
pruneHomeUnitEnv HomeUnitEnv
hme = do
          HomePackageTable
emptyHPT <- IO HomePackageTable -> m HomePackageTable
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO HomePackageTable
emptyHomePackageTable
          HomeUnitEnv -> m HomeUnitEnv
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HomeUnitEnv -> m HomeUnitEnv) -> HomeUnitEnv -> m HomeUnitEnv
forall a b. (a -> b) -> a -> b
$! HomeUnitEnv
hme{ homeUnitEnv_hpt = emptyHPT }
    UnitEnvGraph HomeUnitEnv
hug' <- (HomeUnitEnv -> m HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> m (UnitEnvGraph HomeUnitEnv)
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) -> UnitEnvGraph a -> f (UnitEnvGraph b)
traverse HomeUnitEnv -> m HomeUnitEnv
forall {m :: * -> *}. MonadIO m => HomeUnitEnv -> m HomeUnitEnv
pruneHomeUnitEnv (UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph (UnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnv -> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
    let ue' :: UnitEnv
ue' = (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env){ ue_home_unit_graph = hug' }
    HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC HscEnv
hsc_env{hsc_unit_env = ue' }
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    -- Unload everything
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> IO ()
unload Interp
interp HscEnv
hsc_env

    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Ready for upsweep")
                                    Int
2 ([BuildPlan] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BuildPlan]
build_plan))

    WorkerLimit
worker_limit <- IO WorkerLimit -> m WorkerLimit
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WorkerLimit -> m WorkerLimit)
-> IO WorkerLimit -> m WorkerLimit
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO WorkerLimit
mkWorkerLimit DynFlags
dflags

    (SuccessFlag
upsweep_ok, [HomeModInfo]
new_deps) <- m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics (m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo]))
-> m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall a b. (a -> b) -> a -> b
$ do
      HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
      IO (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo]))
-> IO (SuccessFlag, [HomeModInfo])
-> m (SuccessFlag, [HomeModInfo])
forall a b. (a -> b) -> a -> b
$ WorkerLimit
-> HscEnv
-> Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, [HomeModInfo])
upsweep WorkerLimit
worker_limit HscEnv
hsc_env Maybe ModIfaceCache
mhmi_cache GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessage ([HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
pruned_cache) [BuildPlan]
build_plan

    -- At this point, all the HPT variables will be populated, but we don't want
    -- to leak the contents of a failed session.
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [HomeModInfo] -> HscEnv -> IO ()
restrictDepsHscEnv [HomeModInfo]
new_deps HscEnv
hsc_env
    case SuccessFlag
upsweep_ok of
      SuccessFlag
Failed -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
upsweep_ok
      SuccessFlag
Succeeded -> do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Upsweep completely successful.")
          SuccessFlag -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
upsweep_ok



-- | Finish up after a load.
loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag
-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
loadFinish :: forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
all_ok
  = do (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardIC
       return SuccessFlag
all_ok


-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
guessOutputFile :: GhcMonad m => m ()
guessOutputFile :: forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
env ->
    -- Force mod_graph to avoid leaking env
    let !mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
        new_home_graph :: UnitEnvGraph HomeUnitEnv
new_home_graph =
          ((HomeUnitEnv -> HomeUnitEnv)
 -> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> (HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b) -> UnitEnvGraph a -> UnitEnvGraph b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
env) ((HomeUnitEnv -> HomeUnitEnv) -> UnitEnvGraph HomeUnitEnv)
-> (HomeUnitEnv -> HomeUnitEnv) -> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ \HomeUnitEnv
hue ->
            let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue
                platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
                mainModuleSrcPath :: Maybe String
                mainModuleSrcPath :: Maybe String
mainModuleSrcPath = do
                  ModuleNodeInfo
ms <- ModuleGraph -> Module -> Maybe ModuleNodeInfo
mgLookupModule ModuleGraph
mod_graph (HomeUnitEnv -> Module
mainModIs HomeUnitEnv
hue)
                  ModLocation -> Maybe String
ml_hs_file (ModuleNodeInfo -> ModLocation
moduleNodeInfoLocation ModuleNodeInfo
ms)
                name :: Maybe String
name = (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
dropExtension Maybe String
mainModuleSrcPath

                -- MP: This exception is quite sensitive to being forced, if you
                -- force it here then the error message is different because it gets
                -- caught by a different error handler than the test (T9930fail) expects.
                -- Putting an exception into DynFlags is probably not a great design but
                -- I'll write this comment rather than more eagerly force the exception.
                name_exe :: Maybe String
name_exe = do
                  -- we must add the .exe extension unconditionally here, otherwise
                  -- when name has an extension of its own, the .exe extension will
                 -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248
                 !String
name' <- case Platform -> ArchOS
platformArchOS Platform
platform of
                             ArchOS Arch
_ OS
OSMinGW32  -> (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
<.> String
"exe") Maybe String
name
                             ArchOS Arch
ArchWasm32 OS
_ -> (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
<.> String
"wasm") Maybe String
name
                             ArchOS
_ -> Maybe String
name
                 String
mainModuleSrcPath' <- Maybe String
mainModuleSrcPath
                 -- #9930: don't clobber input files (unless they ask for it)
                 if String
name' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mainModuleSrcPath'
                   then GhcException -> Maybe String
forall a. GhcException -> a
throwGhcException (GhcException -> Maybe String)
-> (String -> GhcException) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
UsageError (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
                        String
"default output name would overwrite the input file; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
"must specify -o explicitly"
                   else String -> Maybe String
forall a. a -> Maybe a
Just String
name'
            in
              case DynFlags -> Maybe String
outputFile_ DynFlags
dflags of
                Just String
_ -> HomeUnitEnv
hue
                Maybe String
Nothing -> HomeUnitEnv
hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }
    in HscEnv
env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }

-- -----------------------------------------------------------------------------
--
-- | Prune the HomePackageTable
--
-- Before doing an upsweep, we can throw away:
--
--   - all ModDetails, all linked code
--   - all unlinked code that is out of date with respect to
--     the source file
--
-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
-- space at the end of the upsweep, because the topmost ModDetails of the
-- old HPT holds on to the entire type environment from the previous
-- compilation.
-- Note [GHC Heap Invariants]
pruneCache :: [CachedIface]
                      -> [ModSummary]
                      -> [HomeModInfo]
pruneCache :: [CachedIface] -> [ModSummary] -> [HomeModInfo]
pruneCache [CachedIface]
hpt [ModSummary]
summ
  = (CachedIface -> HomeModInfo) -> [CachedIface] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
strictMap CachedIface -> HomeModInfo
prune [CachedIface]
hpt
  where prune :: CachedIface -> HomeModInfo
prune (CachedIface { cached_modiface :: CachedIface -> ModIface
cached_modiface = ModIface
iface
                           , cached_linkable :: CachedIface -> HomeModLinkable
cached_linkable = HomeModLinkable
linkable
                           }) = ModIface -> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
emptyModDetails HomeModLinkable
linkable'
          where
           modl :: ModNodeKeyWithUid
modl = ModIface -> ModNodeKeyWithUid
miKey ModIface
iface
           linkable' :: HomeModLinkable
linkable'
                | Just ModSummary
ms <- ModNodeKeyWithUid
-> Map ModNodeKeyWithUid ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModNodeKeyWithUid
modl Map ModNodeKeyWithUid ModSummary
ms_map
                , ModIface -> Maybe Fingerprint
forall (phase :: ModIfacePhase).
ModIface_ phase -> Maybe Fingerprint
mi_src_hash ModIface
iface Maybe Fingerprint -> Maybe Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint -> Maybe Fingerprint
forall a. a -> Maybe a
Just (ModSummary -> Fingerprint
ms_hs_hash ModSummary
ms)
                = HomeModLinkable
linkable
                | Bool
otherwise
                = HomeModLinkable
emptyHomeModInfoLinkable

        -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error.
        ms_map :: Map ModNodeKeyWithUid ModSummary
ms_map = (ModSummary -> ModSummary -> ModSummary)
-> [(ModNodeKeyWithUid, ModSummary)]
-> Map ModNodeKeyWithUid ModSummary
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
                  (\ModSummary
ms1 ModSummary
ms2 -> Bool -> SDoc -> ModSummary -> ModSummary
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"prune_cache" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (ModSummary -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModSummary
ms1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModSummary -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModSummary
ms2))
                               ModSummary
ms2)
                  [(ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms, ModSummary
ms) | ModSummary
ms <- [ModSummary]
summ]

-- ---------------------------------------------------------------------------
--
-- | Unloading
unload :: Interp -> HscEnv -> IO ()
unload :: Interp -> HscEnv -> IO ()
unload Interp
interp HscEnv
hsc_env
  = case DynFlags -> GhcLink
ghcLink (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
        GhcLink
LinkInMemory -> Interp -> HscEnv -> [Linkable] -> IO ()
Linker.unload Interp
interp HscEnv
hsc_env []
        GhcLink
_other -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


{- Parallel Upsweep

The parallel upsweep attempts to concurrently compile the modules in the
compilation graph using multiple Haskell threads.

The Algorithm

* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is
a pair of an `IO a` action and a `MVar a`, where to place the result.
  The list is sorted topologically, so can be executed in order without fear of
  blocking.
* runPipelines takes this list and eventually passes it to runLoop which executes
  each action and places the result into the right MVar.
* The amount of parallelism is controlled by a semaphore. This is just used around the
  module compilation step, so that only the right number of modules are compiled at
  the same time which reduces overall memory usage and allocations.
* Each proper node has a LogQueue, which dictates where to send it's output.
* The LogQueue is placed into the LogQueueQueue when the action starts and a worker
  thread processes the LogQueueQueue printing logs for each module in a stable order.
* The result variable for an action producing `a` is of type `Maybe a`, therefore
  it is still filled on a failure. If a module fails to compile, the
  failure is propagated through the whole module graph and any modules which didn't
  depend on the failure can still be compiled. This behaviour also makes the code
  quite a bit cleaner.
-}


{-

Note [--make mode]
~~~~~~~~~~~~~~~~~
There are two main parts to `--make` mode.

1. `downsweep`: Starts from the top of the module graph and computes dependencies.
2. `upsweep`: Starts from the bottom of the module graph and compiles modules.

The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which
computers how to build this ModuleGraph.

Note [Upsweep]
~~~~~~~~~~~~~~
Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes
the plan in order to compile the project.

The first step is computing the build plan from a 'ModuleGraph'.

The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for
how to build all the modules.

```
data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle
               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot]   -- A resolved cycle, linearised by hs-boot files
               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files
```

The plan is computed in two steps:

Step 1:  Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains
         cycles.
Step 2:  For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should
         result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.
Step 2a: For each module in the cycle, if the module has a boot file then compute the
         modules on the path between it and the hs-boot file.
         These are the intermediate modules which:
            (1) are (transitive) dependencies of the non-boot module, and
            (2) have the boot module as a (transitive) dependency.
         In particular, all such intermediate modules must appear in the same unit as
         the module under consideration, as module cycles cannot cross unit boundaries.
         This information is stored in ModuleGraphNodeWithBoot.

The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.

* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.
* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented
  with a consistent knot-tied version of modules at the end.
    - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration
      is performed both before and after the module in question is compiled.
      See Note [Hydrating Modules] for more information.
* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files
  and are reported as an error to the user.

The main trickiness of `interpretBuildPlan` is deciding which version of a dependency
is visible from each module. For modules which are not in a cycle, there is just
one version of a module, so that is always used. For modules in a cycle, there are two versions of
'HomeModInfo'.

1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.
2. External to loop: The knot-tied version created by typecheckLoop.

Whilst compiling a module inside the loop, we need to use the (1). For a module which
is outside of the loop which depends on something from in the loop, the (2) version
is used.

As the plan is interpreted, which version of a HomeModInfo is visible is updated
by updating a map held in a state monad. So after a loop has finished being compiled,
the visible module is the one created by typecheckLoop and the internal version is not
used again.

This plan also ensures the most important invariant to do with module loops:

> If you depend on anything within a module loop, before you can use the dependency,
  the whole loop has to finish compiling.

The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs
of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running
the action. This list is topologically sorted, so can be run in order to compute
the whole graph.

As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which
can be queried at the end to get the result of all modules at the end, with their proper
visibility. For example, if any module in a loop fails then all modules in that loop will
report as failed because the visible node at the end will be the result of checking
these modules together.

-}

-- | Simple wrapper around MVar which allows a functor instance.
data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))

deriving instance Functor ResultVar

mkResultVar :: MVar (Maybe a) -> ResultVar a
mkResultVar :: forall a. MVar (Maybe a) -> ResultVar a
mkResultVar = (a -> a) -> MVar (Maybe a) -> ResultVar a
forall b a. (a -> b) -> MVar (Maybe a) -> ResultVar b
ResultVar a -> a
forall a. a -> a
id

-- | Block until the result is ready.
waitResult :: ResultVar a -> MaybeT IO a
waitResult :: forall a. ResultVar a -> MaybeT IO a
waitResult (ResultVar a -> a
f MVar (Maybe a)
var) = IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((a -> a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f (Maybe a -> Maybe a) -> IO (Maybe a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Maybe a) -> IO (Maybe a)
forall a. MVar a -> IO a
readMVar MVar (Maybe a)
var)

data BuildResult = BuildResult { BuildResult -> ResultOrigin
_resultOrigin :: ResultOrigin
                               , BuildResult -> ResultVar (Maybe HomeModInfo)
resultVar    :: ResultVar (Maybe HomeModInfo)
                               }

-- The origin of this result var, useful for debugging
data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Int -> ResultOrigin -> String -> String
[ResultOrigin] -> String -> String
ResultOrigin -> String
(Int -> ResultOrigin -> String -> String)
-> (ResultOrigin -> String)
-> ([ResultOrigin] -> String -> String)
-> Show ResultOrigin
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ResultOrigin -> String -> String
showsPrec :: Int -> ResultOrigin -> String -> String
$cshow :: ResultOrigin -> String
show :: ResultOrigin -> String
$cshowList :: [ResultOrigin] -> String -> String
showList :: [ResultOrigin] -> String -> String
Show)

data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Int -> ResultLoopOrigin -> String -> String
[ResultLoopOrigin] -> String -> String
ResultLoopOrigin -> String
(Int -> ResultLoopOrigin -> String -> String)
-> (ResultLoopOrigin -> String)
-> ([ResultLoopOrigin] -> String -> String)
-> Show ResultLoopOrigin
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ResultLoopOrigin -> String -> String
showsPrec :: Int -> ResultLoopOrigin -> String -> String
$cshow :: ResultLoopOrigin -> String
show :: ResultLoopOrigin -> String
$cshowList :: [ResultLoopOrigin] -> String -> String
showList :: [ResultLoopOrigin] -> String -> String
Show)

mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult
mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult
mkBuildResult = ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult
BuildResult


data BuildLoopState = BuildLoopState { BuildLoopState -> Map NodeKey BuildResult
buildDep :: M.Map NodeKey BuildResult
                                          -- The current way to build a specific TNodeKey, without cycles this just points to
                                          -- the appropriate result of compiling a module  but with
                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop
                                     , BuildLoopState -> Int
nNODE :: Int
                                     }

nodeId :: BuildM Int
nodeId :: BuildM Int
nodeId = do
  Int
n <- (BuildLoopState -> Int) -> BuildM Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> Int
nNODE
  (BuildLoopState -> BuildLoopState) -> StateT BuildLoopState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { nNODE = n + 1 })
  return Int
n


setModulePipeline :: NodeKey -> BuildResult -> BuildM ()
setModulePipeline :: NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline NodeKey
mgn BuildResult
build_result = do
  (BuildLoopState -> BuildLoopState) -> StateT BuildLoopState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { buildDep = M.insert mgn build_result (buildDep m) })

type BuildMap = M.Map NodeKey BuildResult

getBuildMap :: BuildM BuildMap
getBuildMap :: BuildM (Map NodeKey BuildResult)
getBuildMap = (BuildLoopState -> Map NodeKey BuildResult)
-> BuildM (Map NodeKey BuildResult)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> Map NodeKey BuildResult
buildDep

getDependencies :: [NodeKey] -> BuildMap -> [BuildResult]
getDependencies :: [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies [NodeKey]
direct_deps Map NodeKey BuildResult
build_map =
  (NodeKey -> BuildResult) -> [NodeKey] -> [BuildResult]
forall a b. (a -> b) -> [a] -> [b]
strictMap (Maybe BuildResult -> BuildResult
forall a. HasCallStack => Maybe a -> a
expectJust (Maybe BuildResult -> BuildResult)
-> (NodeKey -> Maybe BuildResult) -> NodeKey -> BuildResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeKey -> Map NodeKey BuildResult -> Maybe BuildResult)
-> Map NodeKey BuildResult -> NodeKey -> Maybe BuildResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip NodeKey -> Map NodeKey BuildResult -> Maybe BuildResult
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map NodeKey BuildResult
build_map) [NodeKey]
direct_deps

type BuildM a = StateT BuildLoopState IO a




-- | Given the build plan, creates a graph which indicates where each NodeKey should
-- get its direct dependencies from. This might not be the corresponding build action
-- if the module participates in a loop. This step also labels each node with a number for the output.
-- See Note [Upsweep] for a high-level description.
interpretBuildPlan :: HomeUnitGraph
                   -> Maybe ModIfaceCache
                   -> M.Map ModNodeKeyWithUid HomeModInfo
                   -> [BuildPlan]
                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle
                         , [MakeAction] -- Actions we need to run in order to build everything
                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.
interpretBuildPlan :: UnitEnvGraph HomeUnitEnv
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
     (Maybe [ModuleGraphNode], [MakeAction],
      IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan UnitEnvGraph HomeUnitEnv
hug Maybe ModIfaceCache
mhmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
plan = do
  ((Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans), BuildLoopState
build_map) <- StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
-> BuildLoopState
-> IO ((Maybe [ModuleGraphNode], [MakeAction]), BuildLoopState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ([BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plan) (Map NodeKey BuildResult -> Int -> BuildLoopState
BuildLoopState Map NodeKey BuildResult
forall k a. Map k a
M.empty Int
1)
  let wait :: IO [Maybe (Maybe HomeModInfo)]
wait = Map NodeKey BuildResult -> IO [Maybe (Maybe HomeModInfo)]
forall {k}. Map k BuildResult -> IO [Maybe (Maybe HomeModInfo)]
collect_results (BuildLoopState -> Map NodeKey BuildResult
buildDep BuildLoopState
build_map)
  (Maybe [ModuleGraphNode], [MakeAction],
 IO [Maybe (Maybe HomeModInfo)])
-> IO
     (Maybe [ModuleGraphNode], [MakeAction],
      IO [Maybe (Maybe HomeModInfo)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans, IO [Maybe (Maybe HomeModInfo)]
wait)

  where
    collect_results :: Map k BuildResult -> IO [Maybe (Maybe HomeModInfo)]
collect_results Map k BuildResult
build_map =
      [IO (Maybe (Maybe HomeModInfo))] -> IO [Maybe (Maybe HomeModInfo)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((BuildResult -> IO (Maybe (Maybe HomeModInfo)))
-> [BuildResult] -> [IO (Maybe (Maybe HomeModInfo))]
forall a b. (a -> b) -> [a] -> [b]
map (\BuildResult
br -> ResultVar (Maybe HomeModInfo) -> IO (Maybe (Maybe HomeModInfo))
forall {a}. ResultVar a -> IO (Maybe a)
collect_result (BuildResult -> ResultVar (Maybe HomeModInfo)
resultVar BuildResult
br)) (Map k BuildResult -> [BuildResult]
forall k a. Map k a -> [a]
M.elems Map k BuildResult
build_map))
      where
        collect_result :: ResultVar a -> IO (Maybe a)
collect_result ResultVar a
res_var = MaybeT IO a -> IO (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (ResultVar a -> MaybeT IO a
forall a. ResultVar a -> MaybeT IO a
waitResult ResultVar a
res_var)

    -- Just used for an assertion
    count_mods :: BuildPlan -> Int
    count_mods :: BuildPlan -> Int
count_mods (SingleModule ModuleGraphNode
m) = ModuleGraphNode -> Int
forall {a}. Num a => ModuleGraphNode -> a
count_m ModuleGraphNode
m
    count_mods (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns) = [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns
    count_mods (UnresolvedCycle [ModuleGraphNode]
ns) = [ModuleGraphNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleGraphNode]
ns

    count_m :: ModuleGraphNode -> a
count_m (UnitNode {}) = a
0
    count_m ModuleGraphNode
_ = a
1

    n_mods :: Int
n_mods = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
count_mods [BuildPlan]
plan)

    buildLoop :: [BuildPlan]
              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
    -- Build the abstract pipeline which we can execute
    -- Building finished
    buildLoop :: [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop []           = (Maybe [ModuleGraphNode], [MakeAction])
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [ModuleGraphNode]
forall a. Maybe a
Nothing, [])
    buildLoop (BuildPlan
plan:[BuildPlan]
plans) =
      case BuildPlan
plan of
        -- If there was no cycle, then typecheckLoop is not necessary
        SingleModule ModuleGraphNode
m -> do
          MakeAction
one_plan <- Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> StateT BuildLoopState IO MakeAction
buildSingleModule Maybe [NodeKey]
forall a. Maybe a
Nothing ResultOrigin
NoLoop ModuleGraphNode
m
          (Maybe [ModuleGraphNode]
cycle, [MakeAction]
all_plans) <- [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
          return (Maybe [ModuleGraphNode]
cycle, MakeAction
one_plan MakeAction -> [MakeAction] -> [MakeAction]
forall a. a -> [a] -> [a]
: [MakeAction]
all_plans)

        -- For a resolved cycle, depend on everything in the loop, then update
        -- the cache to point to this node rather than directly to the module build
        -- nodes
        ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms -> do
          [MakeAction]
pipes <- [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> StateT BuildLoopState IO [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
          (Maybe [ModuleGraphNode]
cycle, [MakeAction]
graph) <- [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
          return (Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipes [MakeAction] -> [MakeAction] -> [MakeAction]
forall a. [a] -> [a] -> [a]
++ [MakeAction]
graph)

        -- Can't continue past this point as the cycle is unresolved.
        UnresolvedCycle [ModuleGraphNode]
ns -> (Maybe [ModuleGraphNode], [MakeAction])
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ModuleGraphNode] -> Maybe [ModuleGraphNode]
forall a. a -> Maybe a
Just [ModuleGraphNode]
ns, [])

    buildSingleModule :: Maybe [NodeKey]  -- Modules we need to rehydrate before compiling this module
                      -> ResultOrigin
                      -> ModuleGraphNode          -- The node we are compiling
                      -> BuildM MakeAction
    buildSingleModule :: Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> StateT BuildLoopState IO MakeAction
buildSingleModule Maybe [NodeKey]
rehydrate_nodes ResultOrigin
origin ModuleGraphNode
mod = do
      !Map NodeKey BuildResult
build_map <- BuildM (Map NodeKey BuildResult)
getBuildMap
      -- 1. Get the direct dependencies of this module
      let direct_deps :: [NodeKey]
direct_deps = Bool -> ModuleGraphNode -> [NodeKey]
mgNodeDependencies Bool
False ModuleGraphNode
mod
          -- It's really important to force build_deps, or the whole buildMap is retained,
          -- which would retain all the result variables, preventing us from collecting them
          -- after they are no longer used.
          !build_deps :: [BuildResult]
build_deps = [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies [NodeKey]
direct_deps Map NodeKey BuildResult
build_map
      !RunMakeM (Maybe HomeModInfo)
build_action <-
            case ModuleGraphNode
mod of
              InstantiationNode UnitId
uid InstantiatedUnit
iu -> do
                Int
mod_idx <- BuildM Int
nodeId
                return $ UnitId
-> RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
mgNodeUnitId ModuleGraphNode
mod) (RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo))
-> RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
                  ![HomeModInfo]
_ <- [BuildResult] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
wait_deps [BuildResult]
build_deps
                  Int
-> Int
-> UnitEnvGraph HomeUnitEnv
-> UnitId
-> InstantiatedUnit
-> ReaderT MakeEnv (MaybeT IO) ()
executeInstantiationNode Int
mod_idx Int
n_mods UnitEnvGraph HomeUnitEnv
hug UnitId
uid InstantiatedUnit
iu
                  return Maybe HomeModInfo
forall a. Maybe a
Nothing
              ModuleNode [ModuleNodeEdge]
_build_deps ModuleNodeInfo
ms -> do
                let !old_hmi :: Maybe HomeModInfo
old_hmi = ModNodeKeyWithUid
-> Map ModNodeKeyWithUid HomeModInfo -> Maybe HomeModInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModuleNodeInfo -> ModNodeKeyWithUid
mnKey ModuleNodeInfo
ms) Map ModNodeKeyWithUid HomeModInfo
old_hpt
                    rehydrate_mods :: Maybe [ModuleName]
rehydrate_mods = (NodeKey -> Maybe ModuleName) -> [NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe ModuleName
nodeKeyModName ([NodeKey] -> [ModuleName])
-> Maybe [NodeKey] -> Maybe [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [NodeKey]
rehydrate_nodes
                Int
mod_idx <- BuildM Int
nodeId
                return $ UnitId
-> RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
mgNodeUnitId ModuleGraphNode
mod) (RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo))
-> RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
                     ![HomeModInfo]
_ <- [BuildResult] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
wait_deps [BuildResult]
build_deps
                     HomeModInfo
hmi <- Int
-> Int
-> Maybe HomeModInfo
-> UnitEnvGraph HomeUnitEnv
-> Maybe [ModuleName]
-> ModuleNodeInfo
-> ReaderT MakeEnv (MaybeT IO) HomeModInfo
executeCompileNode Int
mod_idx Int
n_mods Maybe HomeModInfo
old_hmi UnitEnvGraph HomeUnitEnv
hug Maybe [ModuleName]
rehydrate_mods ModuleNodeInfo
ms
                     -- Write the HMI to an external cache (if one exists)
                     -- See Note [Caching HomeModInfo]
                     IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ())
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ()))
-> IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ())
forall a b. (a -> b) -> a -> b
$ Maybe ModIfaceCache -> (ModIfaceCache -> IO ()) -> IO (Maybe ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ModIfaceCache
mhmi_cache ((ModIfaceCache -> IO ()) -> IO (Maybe ()))
-> (ModIfaceCache -> IO ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \ModIfaceCache
hmi_cache -> ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache ModIfaceCache
hmi_cache HomeModInfo
hmi
                     -- Make sure the result is written to the HPT var
                     IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT MakeEnv (MaybeT IO) ())
-> IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> UnitEnvGraph HomeUnitEnv -> IO ()
HUG.addHomeModInfoToHug HomeModInfo
hmi UnitEnvGraph HomeUnitEnv
hug
                     return (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
hmi)
              LinkNode [NodeKey]
_nks UnitId
uid -> do
                  Int
mod_idx <- BuildM Int
nodeId
                  return $ UnitId
-> RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
mgNodeUnitId ModuleGraphNode
mod) (RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo))
-> RunMakeM (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
                    ![HomeModInfo]
_ <- [BuildResult] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
wait_deps [BuildResult]
build_deps
                    UnitEnvGraph HomeUnitEnv
-> (Int, Int)
-> UnitId
-> [NodeKey]
-> ReaderT MakeEnv (MaybeT IO) ()
executeLinkNode UnitEnvGraph HomeUnitEnv
hug (Int
mod_idx, Int
n_mods) UnitId
uid [NodeKey]
direct_deps
                    return Maybe HomeModInfo
forall a. Maybe a
Nothing
              UnitNode {} -> RunMakeM (Maybe HomeModInfo)
-> StateT BuildLoopState IO (RunMakeM (Maybe HomeModInfo))
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RunMakeM (Maybe HomeModInfo)
 -> StateT BuildLoopState IO (RunMakeM (Maybe HomeModInfo)))
-> RunMakeM (Maybe HomeModInfo)
-> StateT BuildLoopState IO (RunMakeM (Maybe HomeModInfo))
forall a b. (a -> b) -> a -> b
$ Maybe HomeModInfo -> RunMakeM (Maybe HomeModInfo)
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HomeModInfo
forall a. Maybe a
Nothing


      MVar (Maybe (Maybe HomeModInfo))
res_var <- IO (MVar (Maybe (Maybe HomeModInfo)))
-> StateT BuildLoopState IO (MVar (Maybe (Maybe HomeModInfo)))
forall a. IO a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar (Maybe (Maybe HomeModInfo)))
forall a. IO (MVar a)
newEmptyMVar
      let result_var :: ResultVar (Maybe HomeModInfo)
result_var = MVar (Maybe (Maybe HomeModInfo)) -> ResultVar (Maybe HomeModInfo)
forall a. MVar (Maybe a) -> ResultVar a
mkResultVar MVar (Maybe (Maybe HomeModInfo))
res_var
      NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mod) (ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult
mkBuildResult ResultOrigin
origin ResultVar (Maybe HomeModInfo)
result_var)
      MakeAction -> StateT BuildLoopState IO MakeAction
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeAction -> StateT BuildLoopState IO MakeAction)
-> MakeAction -> StateT BuildLoopState IO MakeAction
forall a b. (a -> b) -> a -> b
$! (RunMakeM (Maybe HomeModInfo)
-> MVar (Maybe (Maybe HomeModInfo)) -> MakeAction
forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction RunMakeM (Maybe HomeModInfo)
build_action MVar (Maybe (Maybe HomeModInfo))
res_var)


    buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
    buildOneLoopyModule :: ModuleGraphNodeWithBootFile
-> StateT BuildLoopState IO [MakeAction]
buildOneLoopyModule (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [NodeKey]
deps) = do
      MakeAction
ma <- Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> StateT BuildLoopState IO MakeAction
buildSingleModule ([NodeKey] -> Maybe [NodeKey]
forall a. a -> Maybe a
Just [NodeKey]
deps) (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
Initialise) ModuleGraphNode
mn
      -- Rehydration (1) from Note [Hydrating Modules], "Loops with multiple boot files"
      MakeAction
rehydrate_action <- ResultLoopOrigin
-> [GenWithIsBoot NodeKey] -> StateT BuildLoopState IO MakeAction
rehydrateAction ResultLoopOrigin
Rehydrated ((NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
IsBoot) GenWithIsBoot NodeKey
-> [GenWithIsBoot NodeKey] -> [GenWithIsBoot NodeKey]
forall a. a -> [a] -> [a]
: ((NodeKey -> GenWithIsBoot NodeKey)
-> [NodeKey] -> [GenWithIsBoot NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map (\NodeKey
d -> NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB NodeKey
d IsBootInterface
NotBoot) [NodeKey]
deps))
      return $ [MakeAction
ma, MakeAction
rehydrate_action]


    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]
    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> StateT BuildLoopState IO [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms = do
      [MakeAction]
build_modules <- (Either ModuleGraphNode ModuleGraphNodeWithBootFile
 -> StateT BuildLoopState IO [MakeAction])
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> StateT BuildLoopState IO [MakeAction]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM ((ModuleGraphNode -> StateT BuildLoopState IO [MakeAction])
-> (ModuleGraphNodeWithBootFile
    -> StateT BuildLoopState IO [MakeAction])
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> StateT BuildLoopState IO [MakeAction]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((MakeAction -> [MakeAction])
-> StateT BuildLoopState IO MakeAction
-> StateT BuildLoopState IO [MakeAction]
forall a b.
(a -> b)
-> StateT BuildLoopState IO a -> StateT BuildLoopState IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MakeAction -> [MakeAction] -> [MakeAction]
forall a. a -> [a] -> [a]
:[]) (StateT BuildLoopState IO MakeAction
 -> StateT BuildLoopState IO [MakeAction])
-> (ModuleGraphNode -> StateT BuildLoopState IO MakeAction)
-> ModuleGraphNode
-> StateT BuildLoopState IO [MakeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> StateT BuildLoopState IO MakeAction
buildSingleModule Maybe [NodeKey]
forall a. Maybe a
Nothing (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
Initialise)) ModuleGraphNodeWithBootFile
-> StateT BuildLoopState IO [MakeAction]
buildOneLoopyModule) [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
      let extract :: Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey
extract (Left ModuleGraphNode
mn) = NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
NotBoot
          extract (Right (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [NodeKey]
_)) = NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
IsBoot
      let loop_mods :: [GenWithIsBoot NodeKey]
loop_mods = (Either ModuleGraphNode ModuleGraphNodeWithBootFile
 -> GenWithIsBoot NodeKey)
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> [GenWithIsBoot NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey
extract [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
      -- Rehydration (2) from Note [Hydrating Modules], "Loops with multiple boot files"
      -- Fixes the space leak described in that note.
      MakeAction
rehydrate_action <- ResultLoopOrigin
-> [GenWithIsBoot NodeKey] -> StateT BuildLoopState IO MakeAction
rehydrateAction ResultLoopOrigin
Finalised [GenWithIsBoot NodeKey]
loop_mods

      return $ [MakeAction]
build_modules [MakeAction] -> [MakeAction] -> [MakeAction]
forall a. [a] -> [a] -> [a]
++ [MakeAction
rehydrate_action]

    -- An action which rehydrates the given keys
    rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
    rehydrateAction :: ResultLoopOrigin
-> [GenWithIsBoot NodeKey] -> StateT BuildLoopState IO MakeAction
rehydrateAction ResultLoopOrigin
origin [GenWithIsBoot NodeKey]
deps = do
      !Map NodeKey BuildResult
build_map <- BuildM (Map NodeKey BuildResult)
getBuildMap
      MVar (Maybe [HomeModInfo])
res_var <- IO (MVar (Maybe [HomeModInfo]))
-> StateT BuildLoopState IO (MVar (Maybe [HomeModInfo]))
forall a. IO a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar (Maybe [HomeModInfo]))
forall a. IO (MVar a)
newEmptyMVar
      let loop_unit :: UnitId
          !loop_unit :: UnitId
loop_unit = NodeKey -> UnitId
nodeKeyUnitId (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod ([GenWithIsBoot NodeKey] -> GenWithIsBoot NodeKey
forall a. HasCallStack => [a] -> a
head [GenWithIsBoot NodeKey]
deps))
          !build_deps :: [BuildResult]
build_deps = [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies ((GenWithIsBoot NodeKey -> NodeKey)
-> [GenWithIsBoot NodeKey] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod [GenWithIsBoot NodeKey]
deps) Map NodeKey BuildResult
build_map
      let loop_action :: ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
loop_action = UnitId
-> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
-> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
loop_unit (ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
 -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo])
-> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
-> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a b. (a -> b) -> a -> b
$ do
            ![HomeModInfo]
_ <- [BuildResult] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
wait_deps [BuildResult]
build_deps
            HscEnv
hsc_env <- (MakeEnv -> HscEnv) -> ReaderT MakeEnv (MaybeT IO) HscEnv
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> HscEnv
hsc_env
            let mns :: [ModuleName]
                mns :: [ModuleName]
mns = (GenWithIsBoot NodeKey -> Maybe ModuleName)
-> [GenWithIsBoot NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey -> Maybe ModuleName)
-> (GenWithIsBoot NodeKey -> NodeKey)
-> GenWithIsBoot NodeKey
-> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [GenWithIsBoot NodeKey]
deps

            [HomeModInfo]
hmis' <- IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo])
-> IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a b. (a -> b) -> a -> b
$ HscEnv -> [ModuleName] -> IO [HomeModInfo]
rehydrateAfter HscEnv
hsc_env [ModuleName]
mns

            [HomeModInfo]
-> [GenWithIsBoot NodeKey] -> ReaderT MakeEnv (MaybeT IO) ()
forall {m :: * -> *}.
Applicative m =>
[HomeModInfo] -> [GenWithIsBoot NodeKey] -> m ()
checkRehydrationInvariant [HomeModInfo]
hmis' [GenWithIsBoot NodeKey]
deps

            -- Add hydrated interfaces to global variable
            IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT MakeEnv (MaybeT IO) ())
-> IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a b. (a -> b) -> a -> b
$ (HomeModInfo -> IO ()) -> [HomeModInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\HomeModInfo
hmi -> HomeModInfo -> UnitEnvGraph HomeUnitEnv -> IO ()
HUG.addHomeModInfoToHug HomeModInfo
hmi UnitEnvGraph HomeUnitEnv
hug) [HomeModInfo]
hmis'
            return [HomeModInfo]
hmis'

      let fanout :: Int -> ResultVar (Maybe HomeModInfo)
fanout Int
i = HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just (HomeModInfo -> Maybe HomeModInfo)
-> ([HomeModInfo] -> HomeModInfo)
-> [HomeModInfo]
-> Maybe HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([HomeModInfo] -> Int -> HomeModInfo
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) ([HomeModInfo] -> Maybe HomeModInfo)
-> ResultVar [HomeModInfo] -> ResultVar (Maybe HomeModInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Maybe [HomeModInfo]) -> ResultVar [HomeModInfo]
forall a. MVar (Maybe a) -> ResultVar a
mkResultVar MVar (Maybe [HomeModInfo])
res_var
      -- From outside the module loop, anyone must wait for the loop to finish and then
      -- use the result of the rehydrated iface. This makes sure that things not in the
      -- module loop will see the updated interfaces for all the identifiers in the loop.
          boot_key :: NodeKey -> NodeKey
          boot_key :: NodeKey -> NodeKey
boot_key (NodeKey_Module ModNodeKeyWithUid
m) = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid
m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } )
          boot_key NodeKey
k = String -> SDoc -> NodeKey
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"boot_key" (NodeKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr NodeKey
k)

          update_module_pipeline :: (GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ()
update_module_pipeline (GenWithIsBoot NodeKey
m, Int
i) =
            case GenWithIsBoot NodeKey -> IsBootInterface
forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot GenWithIsBoot NodeKey
m of
              IsBootInterface
NotBoot -> NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m) (ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo)
fanout Int
i))
              IsBootInterface
IsBoot -> do
                NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m) (ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo)
fanout Int
i))
                -- SPECIAL: Anything outside the loop needs to see A rather than A.hs-boot
                NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (NodeKey -> NodeKey
boot_key (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m)) (ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo)
fanout Int
i))

      let deps_i :: [(GenWithIsBoot NodeKey, Int)]
deps_i = [GenWithIsBoot NodeKey] -> [Int] -> [(GenWithIsBoot NodeKey, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [GenWithIsBoot NodeKey]
deps [Int
0..]
      ((GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ())
-> [(GenWithIsBoot NodeKey, Int)] -> StateT BuildLoopState IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ()
update_module_pipeline [(GenWithIsBoot NodeKey, Int)]
deps_i

      return $ ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
-> MVar (Maybe [HomeModInfo]) -> MakeAction
forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
loop_action MVar (Maybe [HomeModInfo])
res_var

      -- Checks that the interfaces returned from hydration match-up with the names of the
      -- modules which were fed into the function.
    checkRehydrationInvariant :: [HomeModInfo] -> [GenWithIsBoot NodeKey] -> m ()
checkRehydrationInvariant [HomeModInfo]
hmis [GenWithIsBoot NodeKey]
deps =
        let hmi_names :: [ModuleName]
hmi_names = (HomeModInfo -> ModuleName) -> [HomeModInfo] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (HomeModInfo -> Module) -> HomeModInfo -> ModuleName
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]
hmis
            start :: [ModuleName]
start = (GenWithIsBoot NodeKey -> Maybe ModuleName)
-> [GenWithIsBoot NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey -> Maybe ModuleName)
-> (GenWithIsBoot NodeKey -> NodeKey)
-> GenWithIsBoot NodeKey
-> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [GenWithIsBoot NodeKey]
deps
        in Bool -> SDoc -> m ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ([ModuleName]
hmi_names [ModuleName] -> [ModuleName] -> Bool
forall a. Eq a => a -> a -> Bool
== [ModuleName]
start) (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ ([ModuleName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
hmi_names SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [ModuleName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
start)


withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit :: forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
uid = do
  (MakeEnv -> MakeEnv) -> RunMakeM a -> RunMakeM a
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\MakeEnv
env -> MakeEnv
env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})

upsweep
    :: WorkerLimit -- ^ The number of workers we wish to run in parallel
    -> HscEnv -- ^ The base HscEnv, which is augmented for each module
    -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to
    -> (GhcMessage -> AnyGhcDiagnostic)
    -> Maybe Messager
    -> M.Map ModNodeKeyWithUid HomeModInfo
    -> [BuildPlan]
    -> IO (SuccessFlag, [HomeModInfo])
upsweep :: WorkerLimit
-> HscEnv
-> Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, [HomeModInfo])
upsweep WorkerLimit
n_jobs HscEnv
hsc_env Maybe ModIfaceCache
hmi_cache GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessage Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan = do
    (Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipelines, IO [Maybe (Maybe HomeModInfo)]
collect_result) <- UnitEnvGraph HomeUnitEnv
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
     (Maybe [ModuleGraphNode], [MakeAction],
      IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env) Maybe ModIfaceCache
hmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan
    WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runPipelines WorkerLimit
n_jobs HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessage [MakeAction]
pipelines
    [Maybe (Maybe HomeModInfo)]
res <- IO [Maybe (Maybe HomeModInfo)]
collect_result

    let completed :: [HomeModInfo]
completed = [HomeModInfo
m | Just (Just HomeModInfo
m) <- [Maybe (Maybe HomeModInfo)]
res]

    -- Handle any cycle in the original compilation graph and return the result
    -- of the upsweep.
    case Maybe [ModuleGraphNode]
cycle of
        Just [ModuleGraphNode]
mss -> do
          MsgEnvelope GhcMessage -> IO (SuccessFlag, [HomeModInfo])
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO (SuccessFlag, [HomeModInfo]))
-> MsgEnvelope GhcMessage -> IO (SuccessFlag, [HomeModInfo])
forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode] -> MsgEnvelope GhcMessage
cyclicModuleErr [ModuleGraphNode]
mss
        Maybe [ModuleGraphNode]
Nothing  -> do
          let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf ((Maybe (Maybe HomeModInfo) -> Bool)
-> [Maybe (Maybe HomeModInfo)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe (Maybe HomeModInfo) -> Bool
forall a. Maybe a -> Bool
isJust [Maybe (Maybe HomeModInfo)]
res)
          (SuccessFlag, [HomeModInfo]) -> IO (SuccessFlag, [HomeModInfo])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (SuccessFlag
success_flag, [HomeModInfo]
completed)

toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
toCache :: [HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
hmis = [(ModNodeKeyWithUid, HomeModInfo)]
-> Map ModNodeKeyWithUid HomeModInfo
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ModIface -> ModNodeKeyWithUid
miKey (ModIface -> ModNodeKeyWithUid) -> ModIface -> ModNodeKeyWithUid
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi, HomeModInfo
hmi) | HomeModInfo
hmi <- [HomeModInfo]
hmis])

upsweep_inst :: HscEnv
             -> Maybe Messager
             -> Int  -- index of module
             -> Int  -- total number of modules
             -> UnitId
             -> InstantiatedUnit
             -> IO ()
upsweep_inst :: HscEnv
-> Maybe Messager
-> Int
-> Int
-> UnitId
-> InstantiatedUnit
-> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_index Int
nmods UnitId
uid InstantiatedUnit
iuid = do
        case Maybe Messager
mHscMessage of
            Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int
mod_index, Int
nmods) (CompileReason -> RecompileRequired
NeedsRecompile CompileReason
MustCompile) (UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
uid InstantiatedUnit
iuid)
            Maybe Messager
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> IO ()) -> Hsc () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe ()) -> Hsc ()
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe ()) -> Hsc ())
-> IO (Messages GhcMessage, Maybe ()) -> Hsc ()
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe ())
-> IO (Messages GhcMessage, Maybe ())
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe ())
 -> IO (Messages GhcMessage, Maybe ()))
-> IO (Messages TcRnMessage, Maybe ())
-> IO (Messages GhcMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$ HscEnv -> Unit -> IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit HscEnv
hsc_env (Unit -> IO (Messages TcRnMessage, Maybe ()))
-> Unit -> IO (Messages TcRnMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid
        pure ()

-- | Compile a single module.  Always produce a Linkable for it if
-- successful.  If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
            -> Maybe Messager
            -> Maybe HomeModInfo
            -> ModSummary
            -> Int  -- index of module
            -> Int  -- total number of modules
            -> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> Maybe HomeModInfo
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env Maybe Messager
mHscMessage Maybe HomeModInfo
old_hmi ModSummary
summary Int
mod_index Int
nmods =  do
  HomeModInfo
hmi <- Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> HomeModLinkable
-> IO HomeModInfo
compileOne' Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary
          Int
mod_index Int
nmods (HomeModInfo -> ModIface
hm_iface (HomeModInfo -> ModIface) -> Maybe HomeModInfo -> Maybe ModIface
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HomeModInfo
old_hmi) (HomeModLinkable
-> (HomeModInfo -> HomeModLinkable)
-> Maybe HomeModInfo
-> HomeModLinkable
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HomeModLinkable
emptyHomeModInfoLinkable HomeModInfo -> HomeModLinkable
hm_linkable Maybe HomeModInfo
old_hmi)

  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module
  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I
  -- am unsure if this is sound (wrt running TH splices for example).
  -- This function only does anything if the linkable produced is a BCO, which
  -- used to only happen with the bytecode backend, but with
  -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating
  -- object code, see #25230.
  HomeModInfo -> HscEnv -> IO ()
hscInsertHPT HomeModInfo
hmi HscEnv
hsc_env
  HscEnv -> Maybe Linkable -> IO ()
addSptEntries (HscEnv
hsc_env)
                (HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
hmi)

  return HomeModInfo
hmi

-- | Add the entries from a BCO linkable to the SPT table, see
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
addSptEntries HscEnv
hsc_env Maybe Linkable
mlinkable =
  HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env
     [ SptEntry
spt
     | Linkable
linkable <- Maybe Linkable -> [Linkable]
forall a. Maybe a -> [a]
maybeToList Maybe Linkable
mlinkable
     , CompiledByteCode
bco <- Linkable -> [CompiledByteCode]
linkableBCOs Linkable
linkable
     , SptEntry
spt <- CompiledByteCode -> [SptEntry]
bc_spt_entries CompiledByteCode
bco
     ]


-- Note [When source is considered modified]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- A number of functions in GHC.Driver accept a SourceModified argument, which
-- is part of how GHC determines whether recompilation may be avoided (see the
-- definition of the SourceModified data type for details).
--
-- Determining whether or not a source file is considered modified depends not
-- only on the source file itself, but also on the output files which compiling
-- that module would produce. This is done because GHC supports a number of
-- flags which control which output files should be produced, e.g. -fno-code
-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the
-- source file has been modified since the last compile, but also whether the
-- source file has been modified since the last compile which produced all of
-- the output files which have been requested.
--
-- Specifically, a source file is considered unmodified if it is up-to-date
-- relative to all of the output files which have been requested. Whether or
-- not an output file is up-to-date depends on what kind of file it is:
--
-- * iface (.hi) files are considered up-to-date if (and only if) their
--   mi_src_hash field matches the hash of the source file,
--
-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date
--   if (and only if) their modification times on the filesystem are greater
--   than or equal to the modification time of the corresponding .hi file.
--
-- Why do we use '>=' rather than '>' for output files other than the .hi file?
-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a
-- resolution of 2 seconds), we may often find that the .hi and .o files have
-- the same modification time. Using >= is slightly unsafe, but it matches
-- make's behaviour.
--
-- This strategy allows us to do the minimum work necessary in order to ensure
-- that all the files the user cares about are up-to-date; e.g. we should not
-- worry about .o files if the user has indicated that they are not interested
-- in them via -fno-code. See also #9243.
--
-- Note that recompilation avoidance is dependent on .hi files being produced,
-- which does not happen if -fno-write-interface -fno-code is passed. That is,
-- passing -fno-write-interface -fno-code means that you cannot benefit from
-- recompilation avoidance. See also Note [-fno-code mode].
--
-- The correctness of this strategy depends on an assumption that whenever we
-- are producing multiple output files, the .hi file is always written first.
-- If this assumption is violated, we risk recompiling unnecessarily by
-- incorrectly regarding non-.hi files as outdated.
--

-- ---------------------------------------------------------------------------
--
-- | Topological sort of the module graph
topSortModuleGraph
          :: Bool
          -- ^ Drop hi-boot nodes? (see below)
          -> ModuleGraph
          -> Maybe HomeUnitModule
             -- ^ Root module name.  If @Nothing@, use the full graph.
          -> [SCC ModuleGraphNode]
-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
-- The resulting list of strongly-connected-components is in topologically
-- sorted order, starting with the module(s) at the bottom of the
-- dependency graph (ie compile them first) and ending with the ones at
-- the top.
--
-- Drop hi-boot nodes (first boolean arg)?
--
-- - @False@:   treat the hi-boot summaries as nodes of the graph,
--              so the graph must be acyclic
--
-- - @True@:    eliminate the hi-boot nodes, and instead pretend
--              the a source-import of Foo is an import of Foo
--              The resulting graph has no hi-boot nodes, but can be cyclic
topSortModuleGraph :: Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
drop_hs_boot_nodes ModuleGraph
module_graph Maybe HomeUnitModule
mb_root_mod =
  Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
drop_hs_boot_nodes
    ((ModuleGraphNode -> ModuleGraphNode -> Ordering)
-> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (NodeKey -> NodeKey -> Ordering
cmpModuleGraphNodes (NodeKey -> NodeKey -> Ordering)
-> (ModuleGraphNode -> NodeKey)
-> ModuleGraphNode
-> ModuleGraphNode
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ModuleGraphNode -> NodeKey
mkNodeKey) ([ModuleGraphNode] -> [ModuleGraphNode])
-> [ModuleGraphNode] -> [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
module_graph)
    Maybe HomeUnitModule
mb_root_mod


  where
    -- In order to get the "right" ordering
    --    Module nodes must be in reverse lexigraphic order.
    --    All modules nodes must appear before package nodes.
    --
    -- MP: This is just the ordering which the tests needed in Jan 2025, it does
    --     not arise from nature.
    --
    -- Given the current implementation of scc, the result is in
    -- The order is sensitive to the internal implementation in Data.Graph,
    -- if it changes in future then this ordering will need to be modified.
    --
    -- The SCC algorithm firstly transposes the input graph and then
    -- performs dfs on the vertices in the order which they are originally given.
    -- Therefore, if `ExternalUnit` nodes are first, the order returned will
    -- be determined by the order the dependencies are stored in the transposed graph.
    moduleGraphNodeRank :: NodeKey -> Int
    moduleGraphNodeRank :: NodeKey -> Int
moduleGraphNodeRank NodeKey
k =
      case NodeKey
k of
        NodeKey_Unit {}         -> Int
0
        NodeKey_Module {}       -> Int
1
        NodeKey_Link {}         -> Int
2
        NodeKey_ExternalUnit {} -> Int
3

    cmpModuleGraphNodes :: NodeKey -> NodeKey -> Ordering
cmpModuleGraphNodes NodeKey
k1 NodeKey
k2 = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NodeKey -> Int
moduleGraphNodeRank NodeKey
k1) (NodeKey -> Int
moduleGraphNodeRank NodeKey
k2)
                                  Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` NodeKey -> NodeKey -> Ordering
forall a. Ord a => a -> a -> Ordering
compare NodeKey
k2 NodeKey
k1

topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModules :: Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries Maybe HomeUnitModule
mb_root_mod
  = (SCC SummaryNode -> SCC ModuleGraphNode)
-> [SCC SummaryNode] -> [SCC ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map ((SummaryNode -> ModuleGraphNode)
-> SCC SummaryNode -> SCC ModuleGraphNode
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> ModuleGraphNode
summaryNodeSummary) ([SCC SummaryNode] -> [SCC ModuleGraphNode])
-> [SCC SummaryNode] -> [SCC ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ Graph SummaryNode -> [SCC SummaryNode]
forall node. Graph node -> [SCC node]
stronglyConnCompG Graph SummaryNode
initial_graph
  where
    (Graph SummaryNode
graph, NodeKey -> Maybe SummaryNode
lookup_node) =
      Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries

    initial_graph :: Graph SummaryNode
initial_graph = case Maybe HomeUnitModule
mb_root_mod of
        Maybe HomeUnitModule
Nothing -> Graph SummaryNode
graph
        Just (Module UnitId
uid ModuleName
root_mod) ->
            -- restrict the graph to just those modules reachable from
            -- the specified module.  We do this by building a graph with
            -- the full set of nodes, and determining the reachable set from
            -- the specified node.
            let root :: SummaryNode
root | Just SummaryNode
node <- NodeKey -> Maybe SummaryNode
lookup_node (NodeKey -> Maybe SummaryNode) -> NodeKey -> Maybe SummaryNode
forall a b. (a -> b) -> a -> b
$ ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid -> NodeKey) -> ModNodeKeyWithUid -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
root_mod IsBootInterface
NotBoot) UnitId
uid
                     , Graph SummaryNode
graph Graph SummaryNode -> SummaryNode -> Bool
forall node. Graph node -> node -> Bool
`hasVertexG` SummaryNode
node
                     = SummaryNode
node
                     | Bool
otherwise
                     = GhcException -> SummaryNode
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError String
"module does not exist")
            in [SummaryNode] -> Graph SummaryNode
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (SummaryNode -> [SummaryNode] -> [SummaryNode]
forall a b. a -> b -> b
seq SummaryNode
root (SummaryNode
rootSummaryNode -> [SummaryNode] -> [SummaryNode]
forall a. a -> [a] -> [a]
:ReachabilityIndex SummaryNode -> SummaryNode -> [SummaryNode]
forall node. ReachabilityIndex node -> node -> [node]
allReachable (Graph SummaryNode -> ReachabilityIndex SummaryNode
forall node. Graph node -> ReachabilityIndex node
graphReachability Graph SummaryNode
graph) SummaryNode
root))

newtype ModNodeMap a = ModNodeMap { forall a. ModNodeMap a -> Map ModuleNameWithIsBoot a
unModNodeMap :: Map.Map ModNodeKey a }
  deriving ((forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b)
-> (forall a b. a -> ModNodeMap b -> ModNodeMap a)
-> Functor ModNodeMap
forall a b. a -> ModNodeMap b -> ModNodeMap a
forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
fmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
$c<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
Functor, Functor ModNodeMap
Foldable ModNodeMap
(Functor ModNodeMap, Foldable ModNodeMap) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> ModNodeMap a -> f (ModNodeMap b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ModNodeMap (f a) -> f (ModNodeMap a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ModNodeMap a -> m (ModNodeMap b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ModNodeMap (m a) -> m (ModNodeMap a))
-> Traversable ModNodeMap
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
sequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
Traversable, (forall m. Monoid m => ModNodeMap m -> m)
-> (forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m)
-> (forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m)
-> (forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b)
-> (forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b)
-> (forall a. (a -> a -> a) -> ModNodeMap a -> a)
-> (forall a. (a -> a -> a) -> ModNodeMap a -> a)
-> (forall a. ModNodeMap a -> [a])
-> (forall a. ModNodeMap a -> Bool)
-> (forall a. ModNodeMap a -> Int)
-> (forall a. Eq a => a -> ModNodeMap a -> Bool)
-> (forall a. Ord a => ModNodeMap a -> a)
-> (forall a. Ord a => ModNodeMap a -> a)
-> (forall a. Num a => ModNodeMap a -> a)
-> (forall a. Num a => ModNodeMap a -> a)
-> Foldable ModNodeMap
forall a. Eq a => a -> ModNodeMap a -> Bool
forall a. Num a => ModNodeMap a -> a
forall a. Ord a => ModNodeMap a -> a
forall m. Monoid m => ModNodeMap m -> m
forall a. ModNodeMap a -> Bool
forall a. ModNodeMap a -> Int
forall a. ModNodeMap a -> [a]
forall a. (a -> a -> a) -> ModNodeMap a -> a
forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => ModNodeMap m -> m
fold :: forall m. Monoid m => ModNodeMap m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$ctoList :: forall a. ModNodeMap a -> [a]
toList :: forall a. ModNodeMap a -> [a]
$cnull :: forall a. ModNodeMap a -> Bool
null :: forall a. ModNodeMap a -> Bool
$clength :: forall a. ModNodeMap a -> Int
length :: forall a. ModNodeMap a -> Int
$celem :: forall a. Eq a => a -> ModNodeMap a -> Bool
elem :: forall a. Eq a => a -> ModNodeMap a -> Bool
$cmaximum :: forall a. Ord a => ModNodeMap a -> a
maximum :: forall a. Ord a => ModNodeMap a -> a
$cminimum :: forall a. Ord a => ModNodeMap a -> a
minimum :: forall a. Ord a => ModNodeMap a -> a
$csum :: forall a. Num a => ModNodeMap a -> a
sum :: forall a. Num a => ModNodeMap a -> a
$cproduct :: forall a. Num a => ModNodeMap a -> a
product :: forall a. Num a => ModNodeMap a -> a
Foldable)

emptyModNodeMap :: ModNodeMap a
emptyModNodeMap :: forall a. ModNodeMap a
emptyModNodeMap = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap Map ModuleNameWithIsBoot a
forall k a. Map k a
Map.empty

modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert :: forall a. ModuleNameWithIsBoot -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModuleNameWithIsBoot
k a
v (ModNodeMap Map ModuleNameWithIsBoot a
m) = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (ModuleNameWithIsBoot
-> a -> Map ModuleNameWithIsBoot a -> Map ModuleNameWithIsBoot a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModuleNameWithIsBoot
k a
v Map ModuleNameWithIsBoot a
m)

modNodeMapElems :: ModNodeMap a -> [a]
modNodeMapElems :: forall a. ModNodeMap a -> [a]
modNodeMapElems (ModNodeMap Map ModuleNameWithIsBoot a
m) = Map ModuleNameWithIsBoot a -> [a]
forall k a. Map k a -> [a]
Map.elems Map ModuleNameWithIsBoot a
m

modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup :: forall a. ModuleNameWithIsBoot -> ModNodeMap a -> Maybe a
modNodeMapLookup ModuleNameWithIsBoot
k (ModNodeMap Map ModuleNameWithIsBoot a
m) = ModuleNameWithIsBoot -> Map ModuleNameWithIsBoot a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleNameWithIsBoot
k Map ModuleNameWithIsBoot a
m

modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a
modNodeMapSingleton :: forall a. ModuleNameWithIsBoot -> a -> ModNodeMap a
modNodeMapSingleton ModuleNameWithIsBoot
k a
v = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (ModuleNameWithIsBoot -> a -> Map ModuleNameWithIsBoot a
forall k a. k -> a -> Map k a
M.singleton ModuleNameWithIsBoot
k a
v)

modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a
modNodeMapUnionWith :: forall a.
(a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a
modNodeMapUnionWith a -> a -> a
f (ModNodeMap Map ModuleNameWithIsBoot a
m) (ModNodeMap Map ModuleNameWithIsBoot a
n) = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap ((a -> a -> a)
-> Map ModuleNameWithIsBoot a
-> Map ModuleNameWithIsBoot a
-> Map ModuleNameWithIsBoot a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith a -> a -> a
f Map ModuleNameWithIsBoot a
m Map ModuleNameWithIsBoot a
n)

-- | If there are {-# SOURCE #-} imports between strongly connected
-- components in the topological sort, then those imports can
-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
-- were necessary, then the edge would be part of a cycle.
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModuleNodeInfo] -> m ()
warnUnnecessarySourceImports :: forall (m :: * -> *). GhcMonad m => [SCC ModuleNodeInfo] -> m ()
warnUnnecessarySourceImports [SCC ModuleNodeInfo]
sccs = do
  DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts (DynFlags -> DiagOpts) -> m DynFlags -> m DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
Opt_WarnUnusedImports DiagOpts
diag_opts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let check :: [ModuleNodeInfo] -> [MsgEnvelope GhcMessage]
check [ModuleNodeInfo]
ms =
           let mods_in_this_cycle :: [ModuleName]
mods_in_this_cycle = (ModuleNodeInfo -> ModuleName) -> [ModuleNodeInfo] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleNodeInfo -> ModuleName
moduleNodeInfoModuleName [ModuleNodeInfo]
ms in
           [ GenLocated SrcSpan ModuleName -> MsgEnvelope GhcMessage
warn GenLocated SrcSpan ModuleName
i | (ModuleNodeCompile ModSummary
m) <- [ModuleNodeInfo]
ms, GenLocated SrcSpan ModuleName
i <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
m,
                      GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
i ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`  [ModuleName]
mods_in_this_cycle ]

        warn :: Located ModuleName -> MsgEnvelope GhcMessage
        warn :: GenLocated SrcSpan ModuleName -> MsgEnvelope GhcMessage
warn (L SrcSpan
loc ModuleName
mod) = DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts
                                                  SrcSpan
loc (ModuleName -> DriverMessage
DriverUnnecessarySourceImports ModuleName
mod)
    Messages GhcMessage -> m ()
forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage)
-> Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope GhcMessage] -> Bag (MsgEnvelope GhcMessage)
forall a. [a] -> Bag a
listToBag ((SCC ModuleNodeInfo -> [MsgEnvelope GhcMessage])
-> [SCC ModuleNodeInfo] -> [MsgEnvelope GhcMessage]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ModuleNodeInfo] -> [MsgEnvelope GhcMessage]
check ([ModuleNodeInfo] -> [MsgEnvelope GhcMessage])
-> (SCC ModuleNodeInfo -> [ModuleNodeInfo])
-> SCC ModuleNodeInfo
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModuleNodeInfo -> [ModuleNodeInfo]
forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModuleNodeInfo]
sccs))


-----------------------------------------------------------------------------
--                      Error messages
-----------------------------------------------------------------------------

-- Defer and group warning, error and fatal messages so they will not get lost
-- in the regular output.
withDeferredDiagnostics :: GhcMonad m => m a -> m a
withDeferredDiagnostics :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics m a
f = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DeferDiagnostics DynFlags
dflags
  then m a
f
  else do
    IORef [IO ()]
warnings <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    IORef [IO ()]
errors <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    IORef [IO ()]
fatals <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger

    let deferDiagnostics :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
deferDiagnostics LogFlags
_dflags !MessageClass
msgClass !SrcSpan
srcSpan !SDoc
msg = do
          let action :: IO ()
action = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
msgClass SrcSpan
srcSpan SDoc
msg
          case MessageClass
msgClass of
            MCDiagnostic Severity
SevWarning ResolvedDiagnosticReason
_reason Maybe DiagnosticCode
_code
              -> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
warnings (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(![IO ()]
i) -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
            MCDiagnostic Severity
SevError ResolvedDiagnosticReason
_reason Maybe DiagnosticCode
_code
              -> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
errors   (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(![IO ()]
i) -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
            MessageClass
MCFatal
              -> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
fatals   (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(![IO ()]
i) -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
            MessageClass
_ -> IO ()
action

        printDeferredDiagnostics :: m ()
printDeferredDiagnostics = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
          [IORef [IO ()]] -> (IORef [IO ()] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IORef [IO ()]
warnings, IORef [IO ()]
errors, IORef [IO ()]
fatals] ((IORef [IO ()] -> IO ()) -> IO ())
-> (IORef [IO ()] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IORef [IO ()]
ref -> do
            -- This IORef can leak when the dflags leaks, so let us always
            -- reset the content. The lazy variant is used here as we want to force
            -- this error if the IORef is ever accessed again, rather than now.
            -- See #20981 for an issue which discusses this general issue.
            let landmine :: [a]
landmine = if Bool
debugIsOn then String -> [a]
forall a. HasCallStack => String -> a
panic String
"withDeferredDiagnostics: use after free" else []
            [IO ()]
actions <- IORef [IO ()] -> ([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [IO ()]
ref (([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()])
-> ([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> ([IO ()]
forall a. [a]
landmine, [IO ()]
i)
            [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> [IO ()]
forall a. [a] -> [a]
reverse [IO ()]
actions

    m () -> (() -> m ()) -> (() -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
      (((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
 -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
forall (m :: * -> *).
GhcMonad m =>
((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
 -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
pushLogHookM ((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> (LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags
-> MessageClass
-> SrcSpan
-> SDoc
-> IO ()
forall a b. a -> b -> a
const LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
deferDiagnostics))
      (\()
_ -> m ()
forall (m :: * -> *). GhcMonad m => m ()
popLogHookM m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
printDeferredDiagnostics)
      (\()
_ -> m a
f)

noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
-- ToDo: we don't have a proper line number for this error
noModError :: HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
noModError HscEnv
hsc_env SrcSpan
loc ModuleName
wanted_mod FindResult
err
  = SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$
    IfaceMessage -> DriverMessage
DriverInterfaceError (IfaceMessage -> DriverMessage) -> IfaceMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$
    (MissingInterfaceError -> InterfaceLookingFor -> IfaceMessage
Can'tFindInterface (HscEnv -> ModuleName -> FindResult -> MissingInterfaceError
cannotFindModule HscEnv
hsc_env ModuleName
wanted_mod FindResult
err) (ModuleName -> IsBootInterface -> InterfaceLookingFor
LookingForModule ModuleName
wanted_mod IsBootInterface
NotBoot))

{-
noHsFileErr :: SrcSpan -> String -> DriverMessages
noHsFileErr loc path
  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)
  -}



cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage
-- From a strongly connected component we find
-- a single cycle to report
cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage
cyclicModuleErr [ModuleGraphNode]
mss
  = Bool -> MsgEnvelope GhcMessage -> MsgEnvelope GhcMessage
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([ModuleGraphNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleGraphNode]
mss)) (MsgEnvelope GhcMessage -> MsgEnvelope GhcMessage)
-> MsgEnvelope GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
    case [Node NodeKey ModuleGraphNode] -> Maybe [ModuleGraphNode]
forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node NodeKey ModuleGraphNode]
graph of
       Maybe [ModuleGraphNode]
Nothing   -> String -> SDoc -> MsgEnvelope GhcMessage
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unexpected non-cycle" ([ModuleGraphNode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mss)
       Just [ModuleGraphNode]
path -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
src_span (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
                    DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode] -> DriverMessage
DriverModuleGraphCycle [ModuleGraphNode]
path
        where
          src_span :: SrcSpan
src_span = SrcSpan
-> (ModuleNodeInfo -> SrcSpan) -> Maybe ModuleNodeInfo -> SrcSpan
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SrcSpan
noSrcSpan (ModLocation -> SrcSpan
mkFileSrcSpan (ModLocation -> SrcSpan)
-> (ModuleNodeInfo -> ModLocation) -> ModuleNodeInfo -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNodeInfo -> ModLocation
moduleNodeInfoLocation) (ModuleGraphNode -> Maybe ModuleNodeInfo
mgNodeIsModule ([ModuleGraphNode] -> ModuleGraphNode
forall a. HasCallStack => [a] -> a
head [ModuleGraphNode]
path))
  where
    graph :: [Node NodeKey ModuleGraphNode]
    graph :: [Node NodeKey ModuleGraphNode]
graph =
      [ DigraphNode
        { node_payload :: ModuleGraphNode
node_payload = ModuleGraphNode
ms
        , node_key :: NodeKey
node_key = ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
ms
        , node_dependencies :: [NodeKey]
node_dependencies = Bool -> ModuleGraphNode -> [NodeKey]
mgNodeDependencies Bool
False ModuleGraphNode
ms
        }
      | ModuleGraphNode
ms <- [ModuleGraphNode]
mss
      ]

cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe :: forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe Logger
logger TmpFs
tmpfs DynFlags
dflags =
  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags
    then IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Logger -> TmpFs -> IO ()
Logger -> TmpFs -> IO ()
keepCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
    else IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs


-- | Thin each HPT variable to only contain keys from the given dependencies.
-- This is used at the end of upsweep to make sure that only completely successfully loaded
-- modules are visible for subsequent operations.
restrictDepsHscEnv :: [HomeModInfo] -> HscEnv -> IO ()
restrictDepsHscEnv :: [HomeModInfo] -> HscEnv -> IO ()
restrictDepsHscEnv [HomeModInfo]
deps HscEnv
hsc_env =
  let deps_with_unit :: [(UnitId, [HomeModInfo])]
deps_with_unit = ([(UnitId, HomeModInfo)] -> (UnitId, [HomeModInfo]))
-> [[(UnitId, HomeModInfo)]] -> [(UnitId, [HomeModInfo])]
forall a b. (a -> b) -> [a] -> [b]
map (\[(UnitId, HomeModInfo)]
xs -> ((UnitId, HomeModInfo) -> UnitId
forall a b. (a, b) -> a
fst ([(UnitId, HomeModInfo)] -> (UnitId, HomeModInfo)
forall a. HasCallStack => [a] -> a
head [(UnitId, HomeModInfo)]
xs), ((UnitId, HomeModInfo) -> HomeModInfo)
-> [(UnitId, HomeModInfo)] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, HomeModInfo) -> HomeModInfo
forall a b. (a, b) -> b
snd [(UnitId, HomeModInfo)]
xs)) ([[(UnitId, HomeModInfo)]] -> [(UnitId, [HomeModInfo])])
-> [[(UnitId, HomeModInfo)]] -> [(UnitId, [HomeModInfo])]
forall a b. (a -> b) -> a -> b
$ ((UnitId, HomeModInfo) -> (UnitId, HomeModInfo) -> Bool)
-> [(UnitId, HomeModInfo)] -> [[(UnitId, HomeModInfo)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
(==) (UnitId -> UnitId -> Bool)
-> ((UnitId, HomeModInfo) -> UnitId)
-> (UnitId, HomeModInfo)
-> (UnitId, HomeModInfo)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (UnitId, HomeModInfo) -> UnitId
forall a b. (a, b) -> a
fst) (((UnitId, HomeModInfo) -> UnitId)
-> [(UnitId, HomeModInfo)] -> [(UnitId, HomeModInfo)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (UnitId, HomeModInfo) -> UnitId
forall a b. (a, b) -> a
fst ((HomeModInfo -> (UnitId, HomeModInfo))
-> [HomeModInfo] -> [(UnitId, HomeModInfo)]
forall a b. (a -> b) -> [a] -> [b]
map HomeModInfo -> (UnitId, HomeModInfo)
go [HomeModInfo]
deps))
      hug :: UnitEnvGraph HomeUnitEnv
hug = UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph (UnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnv -> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
      go :: HomeModInfo -> (UnitId, HomeModInfo)
go HomeModInfo
hmi = (UnitId
hmi_unit, HomeModInfo
hmi)
        where
          hmi_mod :: Module
hmi_mod  = ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)
          hmi_unit :: UnitId
hmi_unit = Unit -> UnitId
toUnitId (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
hmi_mod)
  in [(UnitId, [HomeModInfo])] -> UnitEnvGraph HomeUnitEnv -> IO ()
HUG.restrictHug [(UnitId, [HomeModInfo])]
deps_with_unit UnitEnvGraph HomeUnitEnv
hug


setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv
setHUG :: UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
deps HscEnv
hsc_env =
  (UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG (UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall a b. a -> b -> a
const (UnitEnvGraph HomeUnitEnv
 -> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ UnitEnvGraph HomeUnitEnv
deps) HscEnv
hsc_env

-- | Wrap an action to catch and handle exceptions.
wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction :: forall a.
(GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction GhcMessage -> AnyGhcDiagnostic
msg_wrapper HscEnv
hsc_env IO a
k = do
  let lcl_logger :: Logger
lcl_logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
      lcl_dynflags :: DynFlags
lcl_dynflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
lcl_dynflags
      logg :: SourceError -> IO ()
logg SourceError
err = Logger
-> DiagnosticOpts (UnknownDiagnostic GhcMessageOpts GhcHint)
-> DiagOpts
-> Messages (UnknownDiagnostic GhcMessageOpts GhcHint)
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
lcl_logger DiagnosticOpts (UnknownDiagnostic GhcMessageOpts GhcHint)
DiagnosticOpts GhcMessage
print_config (DynFlags -> DiagOpts
initDiagOpts DynFlags
lcl_dynflags) (GhcMessage -> AnyGhcDiagnostic
GhcMessage -> UnknownDiagnostic GhcMessageOpts GhcHint
msg_wrapper (GhcMessage -> UnknownDiagnostic GhcMessageOpts GhcHint)
-> Messages GhcMessage
-> Messages (UnknownDiagnostic GhcMessageOpts GhcHint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceError -> Messages GhcMessage
srcErrorMessages SourceError
err)
  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle
  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`
  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to
  -- internally using forkIO.
  Either SomeException a
mres <- IO a -> IO (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ Logger -> IO a -> IO a
forall (m :: * -> *) a. ExceptionMonad m => Logger -> m a -> m a
prettyPrintGhcErrors Logger
lcl_logger (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a
k
  case Either SomeException a
mres of
    Right a
res -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
res
    Left SomeException
exc -> do
        case SomeException -> Maybe SourceError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
          Just (SourceError
err :: SourceError)
            -> SourceError -> IO ()
logg SourceError
err
          Maybe SourceError
Nothing -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
                        -- ThreadKilled in particular needs to actually kill the thread.
                        -- So rethrow that and the other async exceptions
                        Just (SomeAsyncException
err :: SomeAsyncException) -> SomeAsyncException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeAsyncException
err
                        Maybe SomeAsyncException
_ -> Logger -> SDoc -> IO ()
errorMsg Logger
lcl_logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text (SomeException -> String
forall a. Show a => a -> String
show SomeException
exc))
        return Maybe a
forall a. Maybe a
Nothing




executeInstantiationNode :: Int
  -> Int
  -> HomeUnitGraph
  -> UnitId
  -> InstantiatedUnit
  -> RunMakeM ()
executeInstantiationNode :: Int
-> Int
-> UnitEnvGraph HomeUnitEnv
-> UnitId
-> InstantiatedUnit
-> ReaderT MakeEnv (MaybeT IO) ()
executeInstantiationNode Int
k Int
n UnitEnvGraph HomeUnitEnv
deps UnitId
uid InstantiatedUnit
iu = do
        MakeEnv
env <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        -- Output of the logger is mediated by a central worker to
        -- avoid output interleaving
        Maybe Messager
msg <- (MakeEnv -> Maybe Messager)
-> ReaderT MakeEnv (MaybeT IO) (Maybe Messager)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> Maybe Messager
env_messager
        GhcMessage -> UnknownDiagnostic GhcMessageOpts GhcHint
wrapper <- (MakeEnv -> GhcMessage -> UnknownDiagnostic GhcMessageOpts GhcHint)
-> ReaderT
     MakeEnv
     (MaybeT IO)
     (GhcMessage -> UnknownDiagnostic GhcMessageOpts GhcHint)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> GhcMessage -> AnyGhcDiagnostic
MakeEnv -> GhcMessage -> UnknownDiagnostic GhcMessageOpts GhcHint
diag_wrapper
        MaybeT IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO () -> ReaderT MakeEnv (MaybeT IO) ())
-> MaybeT IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe ()) -> MaybeT IO ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe ()) -> MaybeT IO ()) -> IO (Maybe ()) -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> MakeEnv -> (HscEnv -> IO (Maybe ())) -> IO (Maybe ())
forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
env ((HscEnv -> IO (Maybe ())) -> IO (Maybe ()))
-> (HscEnv -> IO (Maybe ())) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
          let lcl_hsc_env :: HscEnv
lcl_hsc_env = UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
deps HscEnv
hsc_env
          in (GhcMessage -> AnyGhcDiagnostic)
-> HscEnv -> IO () -> IO (Maybe ())
forall a.
(GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction GhcMessage -> AnyGhcDiagnostic
GhcMessage -> UnknownDiagnostic GhcMessageOpts GhcHint
wrapper HscEnv
lcl_hsc_env (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
            ()
res <- HscEnv
-> Maybe Messager
-> Int
-> Int
-> UnitId
-> InstantiatedUnit
-> IO ()
upsweep_inst HscEnv
lcl_hsc_env Maybe Messager
msg Int
k Int
n UnitId
uid InstantiatedUnit
iu
            Logger -> TmpFs -> DynFlags -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
            return ()
res


-- | executeCompileNode interprets how --make module should compile a ModuleNode
--
-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check
--    if the interface file exists and is up to date. If it is, we return those.
--    Otherwise, we compile the module and return the new HomeModInfo.
-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface
--    and artifacts from disk.

executeCompileNode :: Int
  -> Int
  -> Maybe HomeModInfo
  -> HomeUnitGraph
  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling
  -> ModuleNodeInfo
  -> RunMakeM HomeModInfo
executeCompileNode :: Int
-> Int
-> Maybe HomeModInfo
-> UnitEnvGraph HomeUnitEnv
-> Maybe [ModuleName]
-> ModuleNodeInfo
-> ReaderT MakeEnv (MaybeT IO) HomeModInfo
executeCompileNode Int
k Int
n !Maybe HomeModInfo
old_hmi UnitEnvGraph HomeUnitEnv
hug Maybe [ModuleName]
mrehydrate_mods ModuleNodeInfo
mni = do
  me :: MakeEnv
me@MakeEnv{Maybe Messager
AbstractSem
HscEnv
GhcMessage -> AnyGhcDiagnostic
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
hsc_env :: MakeEnv -> HscEnv
env_messager :: MakeEnv -> Maybe Messager
diag_wrapper :: MakeEnv -> GhcMessage -> AnyGhcDiagnostic
hsc_env :: HscEnv
compile_sem :: AbstractSem
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: MakeEnv -> AbstractSem
..} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  -- Rehydrate any dependencies if this module had a boot file or is a signature file.
  MaybeT IO HomeModInfo -> ReaderT MakeEnv (MaybeT IO) HomeModInfo
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO HomeModInfo -> ReaderT MakeEnv (MaybeT IO) HomeModInfo)
-> MaybeT IO HomeModInfo -> ReaderT MakeEnv (MaybeT IO) HomeModInfo
forall a b. (a -> b) -> a -> b
$ IO (Maybe HomeModInfo) -> MaybeT IO HomeModInfo
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (AbstractSem -> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ Int
-> MakeEnv
-> (HscEnv -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo)
forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
me ((HscEnv -> IO (Maybe HomeModInfo)) -> IO (Maybe HomeModInfo))
-> (HscEnv -> IO (Maybe HomeModInfo)) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
     HscEnv
hsc_env' <- IO HscEnv -> IO HscEnv
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> IO HscEnv) -> IO HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore (UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
hug HscEnv
hsc_env) ModuleNodeInfo
mni Maybe [ModuleName]
fixed_mrehydrate_mods
     case ModuleNodeInfo
mni of
       ModuleNodeCompile ModSummary
mod -> HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo)
executeCompileNodeWithSource HscEnv
hsc_env' MakeEnv
me  ModSummary
mod
       ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
loc -> HscEnv
-> MakeEnv
-> ModNodeKeyWithUid
-> ModLocation
-> IO (Maybe HomeModInfo)
executeCompileNodeFixed HscEnv
hsc_env' MakeEnv
me ModNodeKeyWithUid
key ModLocation
loc
    )

  where
    fixed_mrehydrate_mods :: Maybe [ModuleName]
fixed_mrehydrate_mods =
      case ModuleNodeInfo -> Maybe HscSource
moduleNodeInfoHscSource ModuleNodeInfo
mni of
        -- MP: It is probably a bit of a misimplementation in backpack that
        -- compiling a signature requires an knot_var for that unit.
        -- If you remove this then a lot of backpack tests fail.
        Just HscSource
HsigFile -> [ModuleName] -> Maybe [ModuleName]
forall a. a -> Maybe a
Just []
        Maybe HscSource
_        -> Maybe [ModuleName]
mrehydrate_mods

    executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo)
    executeCompileNodeFixed :: HscEnv
-> MakeEnv
-> ModNodeKeyWithUid
-> ModLocation
-> IO (Maybe HomeModInfo)
executeCompileNodeFixed HscEnv
hsc_env MakeEnv{GhcMessage -> AnyGhcDiagnostic
diag_wrapper :: MakeEnv -> GhcMessage -> AnyGhcDiagnostic
diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
diag_wrapper, Maybe Messager
env_messager :: MakeEnv -> Maybe Messager
env_messager :: Maybe Messager
env_messager} ModNodeKeyWithUid
mod ModLocation
loc =
      (GhcMessage -> AnyGhcDiagnostic)
-> HscEnv -> IO HomeModInfo -> IO (Maybe HomeModInfo)
forall a.
(GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction GhcMessage -> AnyGhcDiagnostic
diag_wrapper HscEnv
hsc_env (IO HomeModInfo -> IO (Maybe HomeModInfo))
-> IO HomeModInfo -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
        Maybe Messager -> (Messager -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Messager
env_messager ((Messager -> IO ()) -> IO ()) -> (Messager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int
k, Int
n) RecompileRequired
UpToDate ([ModuleNodeEdge] -> ModuleNodeInfo -> ModuleGraphNode
ModuleNode [] (ModNodeKeyWithUid -> ModLocation -> ModuleNodeInfo
ModuleNodeFixed ModNodeKeyWithUid
mod ModLocation
loc))
        MaybeErr ReadInterfaceError ModIface
read_result <- Logger
-> DynFlags
-> NameCache
-> Module
-> String
-> IO (MaybeErr ReadInterfaceError ModIface)
readIface (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (HscEnv -> NameCache
hsc_NC HscEnv
hsc_env) (ModNodeKeyWithUid -> Module
mnkToModule ModNodeKeyWithUid
mod) (ModLocation -> String
ml_hi_file ModLocation
loc)
        case MaybeErr ReadInterfaceError ModIface
read_result of
          M.Failed ReadInterfaceError
interface_err ->
            let mn :: ModuleNameWithIsBoot
mn = ModNodeKeyWithUid -> ModuleNameWithIsBoot
mnkModuleName ModNodeKeyWithUid
mod
                err :: IfaceMessage
err = MissingInterfaceError -> InterfaceLookingFor -> IfaceMessage
Can'tFindInterface (ReadInterfaceError -> MissingInterfaceError
BadIfaceFile ReadInterfaceError
interface_err) (ModuleName -> IsBootInterface -> InterfaceLookingFor
LookingForModule (ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleNameWithIsBoot
mn) (ModuleNameWithIsBoot -> IsBootInterface
forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot ModuleNameWithIsBoot
mn))
            in Messages GhcMessage -> IO HomeModInfo
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (Messages GhcMessage -> IO HomeModInfo)
-> Messages GhcMessage -> IO HomeModInfo
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (DriverMessage -> GhcMessage
GhcDriverMessage (IfaceMessage -> DriverMessage
DriverInterfaceError IfaceMessage
err))
          M.Succeeded ModIface
iface -> do
            ModDetails
details <- HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env ModIface
iface
            Maybe Linkable
mb_object <- Module -> ModLocation -> IO (Maybe Linkable)
findObjectLinkableMaybe (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface) ModLocation
loc
            Maybe Linkable
mb_bytecode <- HscEnv -> ModIface -> ModLocation -> TypeEnv -> IO (Maybe Linkable)
loadIfaceByteCodeLazy HscEnv
hsc_env ModIface
iface ModLocation
loc (ModDetails -> TypeEnv
md_types ModDetails
details)
            let hm_linkable :: HomeModLinkable
hm_linkable = Maybe Linkable -> Maybe Linkable -> HomeModLinkable
HomeModLinkable Maybe Linkable
mb_bytecode Maybe Linkable
mb_object
            HomeModInfo -> IO HomeModInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (ModIface -> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details HomeModLinkable
hm_linkable)

    executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo)
    executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo)
executeCompileNodeWithSource HscEnv
hsc_env MakeEnv{GhcMessage -> AnyGhcDiagnostic
diag_wrapper :: MakeEnv -> GhcMessage -> AnyGhcDiagnostic
diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
diag_wrapper, Maybe Messager
env_messager :: MakeEnv -> Maybe Messager
env_messager :: Maybe Messager
env_messager} ModSummary
mod = do
     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas
         lcl_dynflags :: DynFlags
lcl_dynflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
mod
     let lcl_hsc_env :: HscEnv
lcl_hsc_env =
             -- Localise the hsc_env to use the cached flags
             HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
lcl_dynflags (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$
             HscEnv
hsc_env
     -- Compile the module, locking with a semaphore to avoid too many modules
     -- being compiled at the same time leading to high memory usage.
     (GhcMessage -> AnyGhcDiagnostic)
-> HscEnv -> IO HomeModInfo -> IO (Maybe HomeModInfo)
forall a.
(GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction GhcMessage -> AnyGhcDiagnostic
diag_wrapper HscEnv
lcl_hsc_env (IO HomeModInfo -> IO (Maybe HomeModInfo))
-> IO HomeModInfo -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
      HomeModInfo
res <- HscEnv
-> Maybe Messager
-> Maybe HomeModInfo
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
lcl_hsc_env Maybe Messager
env_messager Maybe HomeModInfo
old_hmi ModSummary
mod Int
k Int
n
      Logger -> TmpFs -> DynFlags -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env) DynFlags
lcl_dynflags
      return HomeModInfo
res


{- Rehydration, see Note [Rehydrating Modules] -}

rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.
          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.
          -> IO [HomeModInfo]
rehydrate :: HscEnv -> [HomeModInfo] -> IO [HomeModInfo]
rehydrate HscEnv
hsc_env [HomeModInfo]
hmis = do
  Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ (
     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Re-hydrating loop: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((HomeModInfo -> Module) -> [HomeModInfo] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (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]
hmis)))
  -- When the HPT was pure we had to tie a knot to update the ModDetails in the
  -- HPT required to update those ModDetails, but since it was made an IORef we
  -- just have to make sure the new ModDetails are "reset" so that the new
  -- modules are looked up in HPT when it is forced. If we didn't "reset" the
  -- ModDetails, modules in a loop would refer the wrong (hs-boot) definitions
  -- (as explained in Note [Rehydrating Modules]).
  [ModDetails]
mds <- SDoc -> HscEnv -> IfG [ModDetails] -> IO [ModDetails]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rehydrate") HscEnv
hsc_env (IfG [ModDetails] -> IO [ModDetails])
-> IfG [ModDetails] -> IO [ModDetails]
forall a b. (a -> b) -> a -> b
$
            (HomeModInfo -> IOEnv (Env IfGblEnv ()) ModDetails)
-> [HomeModInfo] -> IfG [ModDetails]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails)
-> (HomeModInfo -> ModIface)
-> HomeModInfo
-> IOEnv (Env IfGblEnv ()) ModDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
  let new_mods :: [HomeModInfo]
new_mods = [ HomeModInfo
hmi{ hm_details = details }
                 | (HomeModInfo
hmi,ModDetails
details) <- [HomeModInfo] -> [ModDetails] -> [(HomeModInfo, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds
                 ]
  return [HomeModInfo]
new_mods

  where
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env

-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the
-- module currently being compiled.
maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore HscEnv
hsc_env ModuleNodeInfo
_ Maybe [ModuleName]
Nothing = HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
maybeRehydrateBefore HscEnv
hsc_env ModuleNodeInfo
mni (Just [ModuleName]
mns) = do
  ModuleEnv (IORef TypeEnv)
knot_var <- HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env
  let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }
  [HomeModInfo]
hmis <- (ModuleName -> IO HomeModInfo) -> [ModuleName] -> IO [HomeModInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Maybe HomeModInfo -> HomeModInfo)
-> IO (Maybe HomeModInfo) -> IO HomeModInfo
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => Maybe a -> a
expectJust (IO (Maybe HomeModInfo) -> IO HomeModInfo)
-> (ModuleName -> IO (Maybe HomeModInfo))
-> ModuleName
-> IO HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> IO (Maybe HomeModInfo)
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env')) [ModuleName]
mns
  [HomeModInfo]
hmis' <- HscEnv -> [HomeModInfo] -> IO [HomeModInfo]
rehydrate HscEnv
hsc_env' [HomeModInfo]
hmis
  (HomeModInfo -> IO ()) -> [HomeModInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\HomeModInfo
hmi -> HomeModInfo -> UnitEnvGraph HomeUnitEnv -> IO ()
HUG.addHomeModInfoToHug HomeModInfo
hmi (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env')) [HomeModInfo]
hmis'
  return HscEnv
hsc_env'

  where
   initialise_knot_var :: HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env = IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv)))
-> IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv))
forall a b. (a -> b) -> a -> b
$
    let mod_name :: Module
mod_name = Maybe HomeUnit -> Module -> Module
homeModuleInstantiation (HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env) (ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
mni)
    in [(Module, IORef TypeEnv)] -> ModuleEnv (IORef TypeEnv)
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv ([(Module, IORef TypeEnv)] -> ModuleEnv (IORef TypeEnv))
-> (IORef TypeEnv -> [(Module, IORef TypeEnv)])
-> IORef TypeEnv
-> ModuleEnv (IORef TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Module, IORef TypeEnv)
-> [(Module, IORef TypeEnv)] -> [(Module, IORef TypeEnv)]
forall a. a -> [a] -> [a]
:[]) ((Module, IORef TypeEnv) -> [(Module, IORef TypeEnv)])
-> (IORef TypeEnv -> (Module, IORef TypeEnv))
-> IORef TypeEnv
-> [(Module, IORef TypeEnv)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module
mod_name,) (IORef TypeEnv -> ModuleEnv (IORef TypeEnv))
-> IO (IORef TypeEnv) -> IO (ModuleEnv (IORef TypeEnv))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeEnv -> IO (IORef TypeEnv)
forall a. a -> IO (IORef a)
newIORef TypeEnv
emptyTypeEnv

rehydrateAfter :: HscEnv
  -> [ModuleName]
  -> IO [HomeModInfo]
rehydrateAfter :: HscEnv -> [ModuleName] -> IO [HomeModInfo]
rehydrateAfter HscEnv
hsc [ModuleName]
mns = do
  let hpt :: HomePackageTable
hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc
  [HomeModInfo]
hmis <- (ModuleName -> IO HomeModInfo) -> [ModuleName] -> IO [HomeModInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Maybe HomeModInfo -> HomeModInfo)
-> IO (Maybe HomeModInfo) -> IO HomeModInfo
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => Maybe a -> a
expectJust (IO (Maybe HomeModInfo) -> IO HomeModInfo)
-> (ModuleName -> IO (Maybe HomeModInfo))
-> ModuleName
-> IO HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> IO (Maybe HomeModInfo)
lookupHpt HomePackageTable
hpt) [ModuleName]
mns
  HscEnv -> [HomeModInfo] -> IO [HomeModInfo]
rehydrate (HscEnv
hsc { hsc_type_env_vars = emptyKnotVars }) [HomeModInfo]
hmis

{-
Note [Hydrating Modules]
~~~~~~~~~~~~~~~~~~~~~~~~
There are at least 4 different representations of an interface file as described
by this diagram.

------------------------------
|       On-disk M.hi         |
------------------------------
    |             ^
    | Read file   | Write file
    V             |
-------------------------------
|      ByteString             |
-------------------------------
    |             ^
    | Binary.get  | Binary.put
    V             |
--------------------------------
|    ModIface (an acyclic AST) |
--------------------------------
    |           ^
    | hydrate   | mkIfaceTc
    V           |
---------------------------------
|  ModDetails (lots of cycles)  |
---------------------------------

The last step, converting a ModIface into a ModDetails is known as "hydration".

Hydration happens in three different places

* When an interface file is initially loaded from disk, it has to be hydrated.
* When a module is finished compiling, we hydrate the ModIface in order to generate
  the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])
* When dealing with boot files and module loops (see Note [Rehydrating Modules])

Note [Rehydrating Modules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a module has a boot file then it is critical to rehydrate the modules on
the path between the two (see #20561).

Suppose we have ("R" for "recursive"):
```
R.hs-boot:   module R where
               data T
               g :: T -> T

A.hs:        module A( f, T, g ) where
                import {-# SOURCE #-} R
                data S = MkS T
                f :: T -> S = ...g...

R.hs:        module R where
                import A
                data T = T1 | T2 S
                g = ...f...
```

== Why we need to rehydrate A's ModIface before compiling R.hs

After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type
that uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same
AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about
it.)

When compiling R.hs, we build a TyCon for `T`.  But that TyCon mentions `S`, and
it currently has an AbstractTyCon for `T` inside it.  But we want to build a
fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.

Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the
ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call
`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation
step, no type inference, just lookups.

Now `S` will be bound to a thunk that, when forced, will "see" the final binding
for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).
But note that this must be done *before* compiling R.hs.

== Why we need to rehydrate A's ModIface after compiling R.hs

When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding
mentions the `LocalId` for `g`.  But when we finish R, we carefully ensure that
all those `LocalIds` are turned into completed `GlobalIds`, replete with
unfoldings etc.   Alas, that will not apply to the occurrences of `g` in `f`'s
unfolding. And if we leave matters like that, they will stay that way, and *all*
subsequent modules that import A will see a crippled unfolding for `f`.

Solution: rehydrate both R and A's ModIface together, right after completing R.hs.

~~ Which modules to rehydrate

We only need rehydrate modules that are
* Below R.hs
* Above R.hs-boot

There might be many unrelated modules (in the home package) that don't need to be
rehydrated.

== Loops with multiple boot files

It is possible for a module graph to have a loop (SCC, when ignoring boot files)
which requires multiple boot files to break. In this case, we must perform
several hydration steps:
  1. The hydration steps described above, which are necessary for correctness.
  2. An extra hydration step at the end of compiling the entire SCC, in order to
     remove space leaks, as we explain below.

Consider the following example:

   ┌─────┐     ┌─────┐
   │  A  │     │  B  │
   └──┬──┘     └──┬──┘
      │           │
  ┌───▼───────────▼───┐
  │         C         │
  └───┬───────────┬───┘
      │           │
 ┌────▼───┐   ┌───▼────┐
 │ A-boot │   │ B-boot │
 └────────┘   └────────┘

A, B and C live together in a SCC. Suppose that we compile the modules in the
order:

  A-boot, B-boot, C, A, B.

When we come to compile A, we will perform the necessary hydration steps,
because A has a boot file. This means that C will be hydrated relative to A,
and the ModDetails for A will reference C/A. Then, when B is compiled,
C will be rehydrated again, and so B will reference C/A,B. At this point,
its interface will be hydrated relative to both A and B.
This causes a space leak: there are now two different copies of C's ModDetails,
kept alive by modules A and B. This is especially problematic if C is large.

The way to avoid this space leak is to rehydrate an entire SCC together at the
end of compilation, so that all the ModDetails point to interfaces for .hs files.
In this example, when we hydrate A, B and C together, then both A and B will refer to
C/A,B.

See #21900 for some more discussion.

== Modules "above" the loop

This dark corner is the subject of #14092.

Suppose we add to our example
```
X.hs     module X where
           import A
           data XT = MkX T
           fx = ...g...
```
If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the argument type of `MkX`.  So:

* Either we should delay compiling X until after R has been compiled. (This is what we do)
* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.

Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.
#20200 has lots of issues, many of them now fixed;
this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).

The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.
Also closely related are
    * #14092
    * #14103

-}

executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode :: UnitEnvGraph HomeUnitEnv
-> (Int, Int)
-> UnitId
-> [NodeKey]
-> ReaderT MakeEnv (MaybeT IO) ()
executeLinkNode UnitEnvGraph HomeUnitEnv
hug (Int, Int)
kn UnitId
uid [NodeKey]
deps = do
  UnitId
-> ReaderT MakeEnv (MaybeT IO) () -> ReaderT MakeEnv (MaybeT IO) ()
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
uid (ReaderT MakeEnv (MaybeT IO) () -> ReaderT MakeEnv (MaybeT IO) ())
-> ReaderT MakeEnv (MaybeT IO) () -> ReaderT MakeEnv (MaybeT IO) ()
forall a b. (a -> b) -> a -> b
$ do
    MakeEnv{Maybe Messager
AbstractSem
HscEnv
GhcMessage -> AnyGhcDiagnostic
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
hsc_env :: MakeEnv -> HscEnv
env_messager :: MakeEnv -> Maybe Messager
diag_wrapper :: MakeEnv -> GhcMessage -> AnyGhcDiagnostic
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: MakeEnv -> AbstractSem
hsc_env :: HscEnv
compile_sem :: AbstractSem
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
..} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let hsc_env' :: HscEnv
hsc_env' = UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
hug HscEnv
hsc_env
        msg' :: Maybe (RecompileRequired -> IO ())
msg' = (\Messager
messager -> \RecompileRequired
recomp -> Messager
messager HscEnv
hsc_env (Int, Int)
kn RecompileRequired
recomp ([NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
deps UnitId
uid)) (Messager -> RecompileRequired -> IO ())
-> Maybe Messager -> Maybe (RecompileRequired -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Messager
env_messager

    SuccessFlag
linkresult <- IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag)
-> IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag
forall a b. (a -> b) -> a -> b
$ AbstractSem -> IO SuccessFlag -> IO SuccessFlag
forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
                            GhcLink
-> Logger
-> TmpFs
-> FinderCache
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
                                (HscEnv -> Logger
hsc_logger HscEnv
hsc_env')
                                (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env')
                                (HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env')
                                (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env')
                                DynFlags
dflags
                                (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env')
                                Bool
True -- We already decided to link
                                Maybe (RecompileRequired -> IO ())
msg'
                                (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env')
    case SuccessFlag
linkresult of
      SuccessFlag
Failed -> String -> ReaderT MakeEnv (MaybeT IO) ()
forall a. String -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Link Failed"
      SuccessFlag
Succeeded -> () -> ReaderT MakeEnv (MaybeT IO) ()
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Wait for dependencies to finish, and then return their results.
wait_deps :: [BuildResult] -> RunMakeM [HomeModInfo]
wait_deps :: [BuildResult] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
wait_deps [] = [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
wait_deps (BuildResult
x:[BuildResult]
xs) = do
  Maybe HomeModInfo
res <- MaybeT IO (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo))
-> MaybeT IO (Maybe HomeModInfo) -> RunMakeM (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ ResultVar (Maybe HomeModInfo) -> MaybeT IO (Maybe HomeModInfo)
forall a. ResultVar a -> MaybeT IO a
waitResult (BuildResult -> ResultVar (Maybe HomeModInfo)
resultVar BuildResult
x)
  [HomeModInfo]
hmis <- [BuildResult] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
wait_deps [BuildResult]
xs
  case Maybe HomeModInfo
res of
    Maybe HomeModInfo
Nothing -> [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [HomeModInfo]
hmis
    Just HomeModInfo
hmi -> [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo
hmiHomeModInfo -> [HomeModInfo] -> [HomeModInfo]
forall a. a -> [a] -> [a]
:[HomeModInfo]
hmis)


{- Note [GHC Heap Invariants]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~
This note is a general place to explain some of the heap invariants which should
hold for a program compiled with --make mode. These invariants are all things
which can be checked easily using ghc-debug.

1. No HomeModInfo are reachable via the EPS.
   Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains
        a reference to the entire HscEnv, if we are not careful the HscEnv will
        contain the HomePackageTable at the time the interface was loaded and
        it will never be released.
   Where? dontLeakTheHUG in GHC.Iface.Load

2. No KnotVars are live at the end of upsweep (#20491)
   Why? KnotVars contains an old stale reference to the TypeEnv for modules
        which participate in a loop. At the end of a loop all the KnotVars references
        should be removed by the call to typecheckLoop.
   Where? typecheckLoop in GHC.Driver.Make.

3. Immediately after a reload, no ModDetails are live.
   Why? During the upsweep all old ModDetails are replaced with a new ModDetails
        generated from a ModIface. If we don't clear the ModDetails before the
        reload takes place then memory usage during the reload is twice as much
        as it should be as we retain a copy of the ModDetails for too long.
   Where? pruneCache in GHC.Driver.Make

4. No TcGblEnv or TcLclEnv are live after typechecking is completed.
   Why? By the time we get to simplification all the data structures from typechecking
        should be eliminated.
   Where? No one place in the compiler. These leaks can be introduced by not suitable
          forcing functions which take a TcLclEnv as an argument.

5. At the end of a successful upsweep, the number of live ModDetails equals the
   number of non-boot Modules.
   Why? Each module has a HomeModInfo which contains a ModDetails from that module.
-}