{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}

-- -----------------------------------------------------------------------------
--
-- (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, checkHomeUnitsClosed,
        load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,
        instantiationNodes,

        downsweep,

        topSortModuleGraph,

        ms_home_srcimps, ms_home_imps,

        summariseModule,
        SummariseResult(..),
        summariseFile,
        hscSourceToIsBoot,
        findExtraSigImports,
        implicitRequirementsShallow,

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

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

import GHC.Prelude
import GHC.Platform

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

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

import GHC.Platform.Ways

import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Phases
import GHC.Driver.Pipeline
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Main

import GHC.Parser.Header

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

import GHC.Data.Bag        ( listToBag )
import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe      ( expectJust )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt

import GHC.Utils.Exception ( throwIO, SomeAsyncException )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Fingerprint
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 Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set

import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.Maybe
import Data.Time
import Data.Bifunctor (first)
import System.Directory
import System.FilePath
import System.IO        ( fixIO )

import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import GHC.Driver.Pipeline.LogQueue
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.Concurrent.STM
import Control.Monad.Trans.Maybe
import GHC.Runtime.Loader
import GHC.Rename.Names
import GHC.Utils.Constants

-- -----------------------------------------------------------------------------
-- 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) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots
    if forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
      else forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (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
            [ModuleName]      -- ^ excluded modules
            -> Bool           -- ^ allow duplicate roots
            -> m (DriverMessages, ModuleGraph)
depanalE :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots = do
    HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    (DriverMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
    if forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
      then do
        HscEnv
hsc_env <- 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
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 forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_home_mod_err
                          forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_pkg_err
                          forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unknown_module_err

        DriverMessages
all_errs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages
one_unit_messages (forall (m :: * -> *) a. Monad m => a -> m a
return forall e. Messages e
emptyMessages) (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env)
        forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (DriverMessage -> GhcMessage
GhcDriverMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DriverMessages
all_errs)
        forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
        pure (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.
        forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
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
    => [ModuleName]  -- ^ excluded modules
    -> Bool          -- ^ allow duplicate roots
    -> m (DriverMessages, ModuleGraph)
    -- ^ possibly empty 'Bag' of errors and a module graph.
depanalPartial :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots = do
  HscEnv
hsc_env <- 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

  forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (FilePath -> SDoc
text FilePath
"Chasing dependencies") (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 ([SDoc] -> SDoc
hcat [
              FilePath -> SDoc
text FilePath
"Chasing modules from: ",
              [SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma (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.
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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, [ModuleGraphNode]
graph_nodes) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep
      HscEnv
hsc_env (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
old_graph)
      [ModuleName]
excluded_mods Bool
allow_dup_roots
    let
      mod_graph :: ModuleGraph
mod_graph = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph [ModuleGraphNode]
graph_nodes
    return (forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages [DriverMessages]
errs, ModuleGraph
mod_graph)

-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.
-- These are used to represent the type checking that is done after
-- all the free holes (sigs in current package) relevant to that instantiation
-- are compiled. This is necessary to catch some instantiation errors.
--
-- In the future, perhaps more of the work of instantiation could be moved here,
-- instead of shoved in with the module compilation nodes. That could simplify
-- backpack, and maybe hs-boot too.
instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes UnitId
uid UnitState
unit_state = UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
uid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InstantiatedUnit]
iuids_to_check
  where
    iuids_to_check :: [InstantiatedUnit]
    iuids_to_check :: [InstantiatedUnit]
iuids_to_check =
      forall a. Ord a => [a] -> [a]
nubSort forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {unit}. GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
unit_state)
     where
      goUnitId :: GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId GenUnit unit
uid =
        [ GenInstantiatedUnit unit
recur
        | VirtUnit GenInstantiatedUnit unit
indef <- [GenUnit unit
uid]
        , (ModuleName, GenModule (GenUnit unit))
inst <- forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit unit
indef
        , GenInstantiatedUnit unit
recur <- (GenInstantiatedUnit unit
indef forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (ModuleName, GenModule (GenUnit unit))
inst
        ]

-- The linking plan for each module. If we need to do linking for a home unit
-- then this function returns a graph node which depends on all the modules in the home unit.

-- At the moment nothing can depend on these LinkNodes.
linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
linkNodes :: [ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue =
  let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue
      ofile :: Maybe FilePath
ofile = DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags

      unit_nodes :: [NodeKey]
      unit_nodes :: [NodeKey]
unit_nodes = forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== UnitId
uid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> UnitId
moduleGraphNodeUnitId) [ModuleGraphNode]
summaries)
  -- Issue a warning for the confusing case where the user
  -- said '-o foo' but we're not going to do any linking.
  -- We attempt linking if either (a) one of the modules is
  -- called Main, or (b) the user said -no-hs-main, indicating
  -- that main() is going to come from somewhere else.
  --
      no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags

      main_sum :: Bool
main_sum = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags) IsBootInterface
NotBoot) UnitId
uid)) [NodeKey]
unit_nodes

      do_linking :: Bool
do_linking =  Bool
main_sum Bool -> Bool -> Bool
|| Bool
no_hs_main Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib

  in if | DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkBinary Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe FilePath
ofile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
do_linking ->
            forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverRedirectedNoMain forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags))
        -- This should be an error, not a warning (#10895).
        | DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
/= GhcLink
NoLink, Bool
do_linking -> forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right ([NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
unit_nodes UnitId
uid))
        | Bool
otherwise  -> forall a. Maybe a
Nothing

-- Note [Missing home modules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
-- in a command line. For example, cabal may want to enable this warning
-- when building a library, so that GHC warns user about modules, not listed
-- neither in `exposed-modules`, nor in `other-modules`.
--
-- Here "home module" means a module, that doesn't come from an other 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 a 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing
      then forall e. Messages e
emptyMessages
      else DriverMessages
warn
  where
    diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags

    is_known_module :: ModSummary -> Bool
is_known_module ModSummary
mod = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> Target -> Bool
is_my_target ModSummary
mod) [Target]
targets

    -- 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_my_target :: ModSummary -> Target -> Bool
is_my_target ModSummary
mod Target
target =
      let tuid :: UnitId
tuid = Target -> UnitId
targetUnitId Target
target
      in case Target -> TargetId
targetId Target
target of
          TargetModule ModuleName
name
            -> forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod) forall a. Eq a => a -> a -> Bool
== ModuleName
name
                Bool -> Bool -> Bool
&& UnitId
tuid forall a. Eq a => a -> a -> Bool
== ModSummary -> UnitId
ms_unitid ModSummary
mod
          TargetFile FilePath
target_file Maybe Phase
_
            | Just FilePath
mod_file <- ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod)
            ->
             DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
target_file forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||

             --  Don't warn on B.hs-boot if B.hs is specified (#16551)
             FilePath -> FilePath
addBootSuffix FilePath
target_file forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||

             --  We can get a file target even if a module name was
             --  originally specified in a command line because it can
             --  be converted in guessTarget (by appending .hs/.lhs).
             --  So let's convert it back and compare with module name
             FilePath -> ModuleName
mkModuleName (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath, FilePath)
splitExtension FilePath
target_file)
              forall a. Eq a => a -> a -> Bool
== forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod)
          TargetId
_ -> Bool
False

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

    warn :: DriverMessages
warn = forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
                         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
  [ModuleName]
reexported_warns <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModuleName -> IO Bool
check_reexport (forall a. Set a -> [a]
Set.toList Set ModuleName
reexported_mods)
  return $ Set ModuleName -> [ModuleName] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ModuleName]
reexported_warns
  where
    diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags

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

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


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

    final_msgs :: Set ModuleName -> [ModuleName] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ModuleName]
reexported_warns
          =
        forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages forall a b. (a -> b) -> a -> b
$
          [DriverMessage -> DriverMessages
warn (UnitId -> [ModuleName] -> DriverMessage
DriverUnknownHiddenModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) (forall a. Set a -> [a]
Set.toList Set ModuleName
hidden_warns)) | Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set ModuleName
hidden_warns)]
          forall a. [a] -> [a] -> [a]
++ [DriverMessage -> DriverMessages
warn (UnitId -> [ModuleName] -> DriverMessage
DriverUnknownReexportedModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) [ModuleName]
reexported_warns) | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
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
_ Maybe Linkable
l) = ModIfaceCache -> CachedIface -> IO ()
iface_addToCache ModIfaceCache
c (ModIface -> Maybe Linkable -> CachedIface
CachedIface ModIface
i Maybe Linkable
l)

data CachedIface = CachedIface { CachedIface -> ModIface
cached_modiface :: !ModIface
                               , CachedIface -> Maybe Linkable
cached_linkable :: !(Maybe Linkable) }

instance Outputable CachedIface where
  ppr :: CachedIface -> SDoc
ppr (CachedIface ModIface
mi Maybe Linkable
ln) = [SDoc] -> SDoc
hsep [FilePath -> SDoc
text FilePath
"CachedIface", forall a. Outputable a => a -> SDoc
ppr (ModIface -> ModNodeKeyWithUid
miKey ModIface
mi), forall a. Outputable a => a -> SDoc
ppr Maybe Linkable
ln]

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

newIfaceCache :: IO ModIfaceCache
newIfaceCache :: IO ModIfaceCache
newIfaceCache = do
  IORef [CachedIface]
ioref <- forall a. a -> IO (IORef a)
newIORef []
  return $
    ModIfaceCache
      { iface_clearCache :: IO [CachedIface]
iface_clearCache = 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 -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [CachedIface]
ioref (\[CachedIface]
c -> (CachedIface
hmiforall 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 = forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
noIfaceCache LoadHowMuch
how_much

mkBatchMsg :: HscEnv -> Messager
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg HscEnv
hsc_env =
  if forall (t :: * -> *) a. Foldable t => t a -> Int
length (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) 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 -> LoadHowMuch -> m SuccessFlag
loadWithCache :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
cache LoadHowMuch
how_much = do
    (DriverMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [] Bool
False                        -- #17459
    Messager
msg <- HscEnv -> Messager
mkBatchMsg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    SuccessFlag
success <- forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' Maybe ModIfaceCache
cache LoadHowMuch
how_much (forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
    if forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
      else forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (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

    -- Only need non-source imports here because SOURCE imports are always HPT
        loadedPackages :: [UnitInfo]
loadedPackages = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(PkgQual
fs, GenLocated SrcSpan ModuleName
mn) -> UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage UnitState
us (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
mn) PkgQual
fs)
            forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps (
              forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> DynFlags -> UnitId
homeUnitId_ DynFlags
dflags forall a. Eq a => a -> a -> Bool
== ModSummary -> UnitId
ms_unitid ModSummary
ms) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph))

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

        resolve :: (GenUnit UnitId, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg)
resolve (GenUnit UnitId
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 -> GenUnit UnitId -> Maybe UnitInfo
lookupUnit UnitState
us GenUnit UnitId
u
                  -- Which are not explicitly used
                  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Ord a => a -> Set a -> Bool
Set.notMember (forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui) Set UnitId
used_args)
                  return (forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui, forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
ui, forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
unitPackageVersion UnitInfo
ui, PackageArg
flag)

        unusedArgs :: [(UnitId, PackageName, Version, PackageArg)]
unusedArgs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (GenUnit UnitId, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg)
resolve (UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
us)

        warn :: DriverMessages
warn = forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitId, PackageName, Version, PackageArg)]
unusedArgs
        then 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 [ModuleGraphNode]

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

getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode
getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode
getNode (ModuleGraphNodeWithBootFile ModuleGraphNode
mgn [ModuleGraphNode]
_) = ModuleGraphNode
mgn
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 ModuleGraphNodeWithBootFile]   -- A resolved cycle, linearised by hs-boot files
               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files

instance Outputable BuildPlan where
  ppr :: BuildPlan -> SDoc
ppr (SingleModule ModuleGraphNode
mgn) = FilePath -> SDoc
text FilePath
"SingleModule" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn)
  ppr (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn)   = FilePath -> SDoc
text FilePath
"ResolvedCycle:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn
  ppr (UnresolvedCycle [ModuleGraphNode]
mgn) = FilePath -> SDoc
text FilePath
"UnresolvedCycle:" SDoc -> SDoc -> 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) = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns
countMods (UnresolvedCycle [ModuleGraphNode]
ns) = 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
          | forall a. ModuleEnv a -> Bool
isEmptyModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic 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
nodeforall 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 :: Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle = [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
nodes)
          in [BuildPlan]
acyclic forall a. [a] -> [a] -> [a]
++ [forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([ModuleGraphNode] -> BuildPlan
UnresolvedCycle [ModuleGraphNode]
nodes) [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildPlan
ResolvedCycle Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle] forall a. [a] -> [a] -> [a]
++ [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
sccs []

        (Graph SummaryNode
mg, NodeKey -> Maybe SummaryNode
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph)
        trans_deps_map :: Map NodeKey (Set NodeKey)
trans_deps_map = forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachable Graph SummaryNode
mg (ModuleGraphNode -> NodeKey
mkNodeKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key payload. Node key payload -> payload
node_payload)
        -- 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 =
          forall a b. (a -> b) -> [a] -> [b]
map (SummaryNode -> ModuleGraphNode
summaryNodeSummary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"toNode" forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
          -- Don't include the boot module itself
          forall a. Ord a => a -> Set a -> Set a
Set.delete (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot))  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.
          forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\NodeKey
nk -> NodeKey -> UnitId
nodeKeyUnitId NodeKey
nk forall a. Eq a => a -> a -> Bool
== UnitId
uid  -- Cheap test
                              Bool -> Bool -> Bool
&& (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot)) forall a. Ord a => a -> Set a -> Bool
`Set.member` forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"dep_on_boot" (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
nk Map NodeKey (Set NodeKey)
trans_deps_map)) forall a b. (a -> b) -> a -> b
$
          forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"not_boot_dep" (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
NotBoot)) Map NodeKey (Set NodeKey)
trans_deps_map)
          where
            key :: IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
ib = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (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 = forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv
          [ (ModSummary -> Module
ms_mod ModSummary
ms, (ModuleGraphNode
m, ModuleName -> UnitId -> [ModuleGraphNode]
boot_path (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) (ModSummary -> UnitId
ms_unitid ModSummary
ms))) | m :: ModuleGraphNode
m@(ModuleNode [NodeKey]
_ ModSummary
ms) <- (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph), ModSummary -> IsBootInterface
isBootSummary ModSummary
ms forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]

        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst 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 ModuleGraphNode
m = case ModuleGraphNode
m of ModuleNode [NodeKey]
_ ModSummary
ms | HscSource
HsSrcFile <- ModSummary -> HscSource
ms_hsc_src ModSummary
ms -> forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules (ModSummary -> Module
ms_mod ModSummary
ms); ModuleGraphNode
_ -> forall a. Maybe a
Nothing

        -- Any cycles should be resolved now
        collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
        -- Must be at least two nodes, as we were in a cycle
        collapseSCC :: [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [AcyclicSCC ModuleGraphNode
node1, AcyclicSCC ModuleGraphNode
node2] = forall a. a -> Maybe a
Just [ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node1, ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node2]
        collapseSCC (AcyclicSCC ModuleGraphNode
node : [SCC ModuleGraphNode]
nodes) = (ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [SCC ModuleGraphNode]
nodes
        -- Cyclic
        collapseSCC [SCC ModuleGraphNode]
_ = forall a. Maybe a
Nothing

        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 -> forall a b. a -> Either a b
Left ModuleGraphNode
mn
            -- The node does have a boot file
            Just (ModuleGraphNode, [ModuleGraphNode])
path -> forall a b. b -> Either a b
Right (ModuleGraphNode -> [ModuleGraphNode] -> ModuleGraphNodeWithBootFile
ModuleGraphNodeWithBootFile ModuleGraphNode
mn (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 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) 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 forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
nodes) forall a. Maybe a
Nothing


  in

    forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan) forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph))
              ([SDoc] -> SDoc
vcat [FilePath -> SDoc
text FilePath
"Build plan missing nodes:", (FilePath -> SDoc
text FilePath
"PLAN:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan))), (FilePath -> SDoc
text FilePath
"GRAPH:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' 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 -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' Maybe ModIfaceCache
mhmi_cache LoadHowMuch
how_much Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
    forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
    forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
    HscEnv
hsc_env <- 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 =
          forall a. Ord a => [a] -> Set a
Set.fromList [ 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 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
_ = forall a. a -> a
id

        checkMod :: HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m m SuccessFlag
and_then
            | HomeUnitModule
m forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HomeUnitModule
all_home_mods = m SuccessFlag
and_then
            | Bool
otherwise = do
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
errorMsg Logger
logger
                        (FilePath -> SDoc
text FilePath
"no such module:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> unit
moduleUnit HomeUnitModule
m) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName HomeUnitModule
m)))
                    return SuccessFlag
Failed

    LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch LoadHowMuch
how_much 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 unecessary 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 forall a. Maybe a
Nothing

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

    let maybe_top_mod :: Maybe HomeUnitModule
maybe_top_mod = case LoadHowMuch
how_much of
                          LoadUpTo HomeUnitModule
m           -> forall a. a -> Maybe a
Just HomeUnitModule
m
                          LoadDependenciesOf HomeUnitModule
m -> forall a. a -> Maybe a
Just HomeUnitModule
m
                          LoadHowMuch
_                    -> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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
                            (forall a. [SCC a] -> [a]
flattenSCCs ([SCC ModuleGraphNode] -> [SCC ModSummary]
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 -> HomeUnitEnv
pruneHomeUnitEnv HomeUnitEnv
hme = HomeUnitEnv
hme { homeUnitEnv_hpt :: HomePackageTable
homeUnitEnv_hpt = HomePackageTable
emptyHomePackageTable }
    forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC forall a b. (a -> b) -> a -> b
$ (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG (forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv) HscEnv
hsc_env

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

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

    Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
                    Maybe Int
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
                    Just Int
n  -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

    forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG (forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv) HscEnv
hsc_env
    (SuccessFlag
upsweep_ok, HscEnv
hsc_env1) <- forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics forall a b. (a -> b) -> a -> b
$ do
      HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> HscEnv
-> Maybe ModIfaceCache
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, HscEnv)
upsweep Int
n_jobs HscEnv
hsc_env Maybe ModIfaceCache
mhmi_cache Maybe Messager
mHscMessage ([HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
pruned_cache) [BuildPlan]
build_plan
    forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env1
    case SuccessFlag
upsweep_ok of
      SuccessFlag
Failed -> forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
upsweep_ok
      SuccessFlag
Succeeded -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (FilePath -> SDoc
text FilePath
"Upsweep completely successful.")
          -- Clean up after ourselves
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe Logger
logger (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env1) DynFlags
dflags
          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 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 = forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession 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 :: HomeUnitGraph
new_home_graph =
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
env) 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 FilePath
mainModuleSrcPath = do
                  ModSummary
ms <- ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph
mod_graph (HomeUnitEnv -> Module
mainModIs HomeUnitEnv
hue)
                  ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
                name :: Maybe FilePath
name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
dropExtension Maybe FilePath
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 FilePath
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
                 !FilePath
name' <- if Platform -> OS
platformOS Platform
platform forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                           then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
<.> FilePath
"exe") Maybe FilePath
name
                           else Maybe FilePath
name
                 FilePath
mainModuleSrcPath' <- Maybe FilePath
mainModuleSrcPath
                 -- #9930: don't clobber input files (unless they ask for it)
                 if FilePath
name' forall a. Eq a => a -> a -> Bool
== FilePath
mainModuleSrcPath'
                   then forall a. GhcException -> a
throwGhcException forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
UsageError forall a b. (a -> b) -> a -> b
$
                        FilePath
"default output name would overwrite the input file; " forall a. [a] -> [a] -> [a]
++
                        FilePath
"must specify -o explicitly"
                   else forall a. a -> Maybe a
Just FilePath
name'
            in
              case DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags of
                Just FilePath
_ -> HomeUnitEnv
hue
                Maybe FilePath
Nothing -> HomeUnitEnv
hue {homeUnitEnv_dflags :: DynFlags
homeUnitEnv_dflags = DynFlags
dflags { outputFile_ :: Maybe FilePath
outputFile_ = Maybe FilePath
name_exe } }
    in HscEnv
env { hsc_unit_env :: UnitEnv
hsc_unit_env = (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env) { ue_home_unit_graph :: HomeUnitGraph
ue_home_unit_graph = HomeUnitGraph
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
  = 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 -> Maybe Linkable
cached_linkable = Maybe Linkable
linkable
                           }) = ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
emptyModDetails Maybe Linkable
linkable'
          where
           modl :: ModNodeKeyWithUid
modl = ModIface -> ModNodeKeyWithUid
miKey ModIface
iface
           linkable' :: Maybe Linkable
linkable'
                | Just ModSummary
ms <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModNodeKeyWithUid
modl Map ModNodeKeyWithUid ModSummary
ms_map
                , forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_src_hash ModIface
iface forall a. Eq a => a -> a -> Bool
/= ModSummary -> Fingerprint
ms_hs_hash ModSummary
ms
                = forall a. Maybe a
Nothing
                | Bool
otherwise
                = Maybe Linkable
linkable

        -- 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 = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
                  (\ModSummary
ms1 ModSummary
ms2 -> forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (FilePath -> SDoc
text FilePath
"prune_cache" SDoc -> SDoc -> SDoc
$$ (forall a. Outputable a => a -> SDoc
ppr ModSummary
ms1 SDoc -> SDoc -> 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 -> 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 parrelism 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 overal 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))

instance Functor ResultVar where
  fmap :: forall a b. (a -> b) -> ResultVar a -> ResultVar b
fmap a -> b
f (ResultVar a -> a
g MVar (Maybe a)
var) = forall b a. (a -> b) -> MVar (Maybe a) -> ResultVar b
ResultVar (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g) MVar (Maybe a)
var

mkResultVar :: MVar (Maybe a) -> ResultVar a
mkResultVar :: forall a. MVar (Maybe a) -> ResultVar a
mkResultVar = forall b a. (a -> b) -> MVar (Maybe a) -> ResultVar b
ResultVar 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) = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO a
readMVar MVar (Maybe a)
var)


data BuildLoopState = BuildLoopState { BuildLoopState -> Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
buildDep :: M.Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
                                          -- The current way to build a specific TNodeKey, without cycles this just points to
                                          -- the appropiate 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
                                     , BuildLoopState -> MVar HomeUnitGraph
hug_var :: MVar HomeUnitGraph
                                     -- A global variable which is incrementally updated with the result
                                     -- of compiling modules.
                                     }

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

setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()
setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()
setModulePipeline NodeKey
mgn SDoc
doc ResultVar (Maybe HomeModInfo)
wrapped_pipeline = do
  forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { buildDep :: Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
buildDep = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeKey
mgn (SDoc
doc, ResultVar (Maybe HomeModInfo)
wrapped_pipeline) (BuildLoopState -> Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
buildDep BuildLoopState
m) })

getBuildMap :: BuildM (M.Map
                    NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))
getBuildMap :: BuildM (Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))
getBuildMap = forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
buildDep

type BuildM a = StateT BuildLoopState IO a


-- | Abstraction over the operations of a semaphore which allows usage with the
--  -j1 case
data AbstractSem = AbstractSem { AbstractSem -> IO ()
acquireSem :: IO ()
                               , AbstractSem -> IO ()
releaseSem :: IO () }

withAbstractSem :: AbstractSem -> IO b -> IO b
withAbstractSem :: forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
sem = forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
MC.bracket_ (AbstractSem -> IO ()
acquireSem AbstractSem
sem) (AbstractSem -> IO ()
releaseSem AbstractSem
sem)

-- | Environment used when compiling a module
data MakeEnv = MakeEnv { MakeEnv -> HscEnv
hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module
                       , MakeEnv -> AbstractSem
compile_sem :: !AbstractSem
                       -- Modify the environment for module k, with the supplied logger modification function.
                       -- For -j1, this wrapper doesn't do anything
                       -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output
                       --          into the log queue.
                       , MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a
                       , MakeEnv -> Maybe Messager
env_messager :: !(Maybe Messager)
                       }

type RunMakeM a = ReaderT MakeEnv (MaybeT 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 :: HomeUnitGraph
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
     (Maybe [ModuleGraphNode], [MakeAction],
      IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan HomeUnitGraph
hug Maybe ModIfaceCache
mhmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
plan = do
  MVar HomeUnitGraph
hug_var <- forall a. a -> IO (MVar a)
newMVar HomeUnitGraph
hug
  ((Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans), BuildLoopState
build_map) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ([BuildPlan] -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plan) (Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
-> Int -> MVar HomeUnitGraph -> BuildLoopState
BuildLoopState forall k a. Map k a
M.empty Int
1 MVar HomeUnitGraph
hug_var)
  let wait :: IO [Maybe (Maybe HomeModInfo)]
wait = forall {k} {a} {a}. Map k (a, ResultVar a) -> IO [Maybe a]
collect_results (BuildLoopState -> Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
buildDep BuildLoopState
build_map)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans, IO [Maybe (Maybe HomeModInfo)]
wait)

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

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

    buildLoop :: [BuildPlan]
              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
    -- Build the abstract pipeline which we can execute
    -- Building finished
    buildLoop :: [BuildPlan] -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop []           = forall (m :: * -> *) a. Monad m => a -> m a
return (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, ResultVar (Maybe HomeModInfo)
_) <- Maybe [ModuleGraphNode]
-> ModuleGraphNode
-> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
buildSingleModule forall a. Maybe a
Nothing ModuleGraphNode
m
          (Maybe [ModuleGraphNode]
cycle, [MakeAction]
all_plans) <- [BuildPlan] -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
          forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [ModuleGraphNode]
cycle, MakeAction
one_plan 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]
-> BuildM [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
          (Maybe [ModuleGraphNode]
cycle, [MakeAction]
graph) <- [BuildPlan] -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
          return (Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipes forall a. [a] -> [a] -> [a]
++ [MakeAction]
graph)

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

    buildSingleModule :: Maybe [ModuleGraphNode]  -- Modules we need to rehydrate before compiling this module
                      -> ModuleGraphNode          -- The node we are compiling
                      -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
    buildSingleModule :: Maybe [ModuleGraphNode]
-> ModuleGraphNode
-> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
buildSingleModule Maybe [ModuleGraphNode]
rehydrate_nodes ModuleGraphNode
mod = do
      Int
mod_idx <- BuildM Int
nodeId
      Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
home_mod_map <- BuildM (Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))
getBuildMap
      MVar HomeUnitGraph
hug_var <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> MVar HomeUnitGraph
hug_var
      -- 1. Get the transitive dependencies of this module, by looking up in the dependency map
      let direct_deps :: [NodeKey]
direct_deps = Bool -> ModuleGraphNode -> [NodeKey]
nodeDependencies Bool
False ModuleGraphNode
mod
          doc_build_deps :: [(SDoc, ResultVar (Maybe HomeModInfo))]
doc_build_deps = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"dep_map" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
home_mod_map) [NodeKey]
direct_deps
          build_deps :: [ResultVar (Maybe HomeModInfo)]
build_deps = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(SDoc, ResultVar (Maybe HomeModInfo))]
doc_build_deps
      -- 2. Set the default way to build this node, not in a loop here
      let build_action :: RunMakeM (Maybe HomeModInfo)
build_action = forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
mod) forall a b. (a -> b) -> a -> b
$
            case ModuleGraphNode
mod of
              InstantiationNode UnitId
uid InstantiatedUnit
iu ->
                forall a b. a -> b -> a
const forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Int
-> RunMakeM HomeUnitGraph
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode Int
mod_idx Int
n_mods (forall b.
MVar b
-> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
wait_deps_hug MVar HomeUnitGraph
hug_var [ResultVar (Maybe HomeModInfo)]
build_deps) UnitId
uid InstantiatedUnit
iu
              ModuleNode [NodeKey]
_build_deps ModSummary
ms -> do
                  let !old_hmi :: Maybe HomeModInfo
old_hmi = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms) Map ModNodeKeyWithUid HomeModInfo
old_hpt
                      rehydrate_mods :: Maybe [ModuleName]
rehydrate_mods = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ModuleGraphNode -> Maybe ModuleName
moduleGraphNodeModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [ModuleGraphNode]
rehydrate_nodes
                  HomeModInfo
hmi <- Int
-> Int
-> Maybe HomeModInfo
-> RunMakeM HomeUnitGraph
-> Maybe [ModuleName]
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode Int
mod_idx Int
n_mods Maybe HomeModInfo
old_hmi (forall b.
MVar b
-> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
wait_deps_hug MVar HomeUnitGraph
hug_var [ResultVar (Maybe HomeModInfo)]
build_deps) Maybe [ModuleName]
rehydrate_mods ModSummary
ms

                  -- Write the HMI to an external cache (if one exists)
                  -- See Note [Caching HomeModInfo]
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ModIfaceCache
mhmi_cache forall a b. (a -> b) -> a -> b
$ \ModIfaceCache
hmi_cache -> ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache ModIfaceCache
hmi_cache HomeModInfo
hmi
                  -- This global MVar is incrementally modified in order to avoid having to
                  -- recreate the HPT before compiling each module which leads to a quadratic amount of work.
                  HscEnv
hsc_env <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> HscEnv
hsc_env
                  HomeModInfo
hmi' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar HomeUnitGraph
hug_var (\HomeUnitGraph
hug -> do
                    let new_hpt :: HomeUnitGraph
new_hpt = HomeModInfo -> HomeUnitGraph -> HomeUnitGraph
addHomeModInfoToHug HomeModInfo
hmi HomeUnitGraph
hug
                        new_hsc :: HscEnv
new_hsc = HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
new_hpt HscEnv
hsc_env
                    HomeModInfo
-> HscEnv -> Maybe [ModuleName] -> IO (HomeUnitGraph, HomeModInfo)
maybeRehydrateAfter HomeModInfo
hmi HscEnv
new_hsc Maybe [ModuleName]
rehydrate_mods
                      )
                  return (forall a. a -> Maybe a
Just HomeModInfo
hmi')
              LinkNode [NodeKey]
_nks UnitId
uid -> do
                  RunMakeM HomeUnitGraph
-> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode (forall b.
MVar b
-> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
wait_deps_hug MVar HomeUnitGraph
hug_var [ResultVar (Maybe HomeModInfo)]
build_deps) (Int
mod_idx, Int
n_mods) UnitId
uid [NodeKey]
direct_deps
                  return forall a. Maybe a
Nothing


      MVar (Maybe (Maybe HomeModInfo))
res_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
newEmptyMVar
      let result_var :: ResultVar (Maybe HomeModInfo)
result_var = forall a. MVar (Maybe a) -> ResultVar a
mkResultVar MVar (Maybe (Maybe HomeModInfo))
res_var
      NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()
setModulePipeline (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mod) (FilePath -> SDoc
text FilePath
"N") ResultVar (Maybe HomeModInfo)
result_var
      return $ (forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction RunMakeM (Maybe HomeModInfo)
build_action MVar (Maybe (Maybe HomeModInfo))
res_var, ResultVar (Maybe HomeModInfo)
result_var)


    buildOneLoopyModule ::  ModuleGraphNodeWithBootFile -> BuildM (MakeAction, (ResultVar (Maybe HomeModInfo)))
    buildOneLoopyModule :: ModuleGraphNodeWithBootFile
-> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
buildOneLoopyModule (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [ModuleGraphNode]
deps) =
      Maybe [ModuleGraphNode]
-> ModuleGraphNode
-> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
buildSingleModule (forall a. a -> Maybe a
Just [ModuleGraphNode]
deps) ModuleGraphNode
mn

    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] ->  BuildM [MakeAction]
    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildM [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms = do
      ([MakeAction]
build_modules, [ResultVar (Maybe HomeModInfo)]
wait_modules) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [ModuleGraphNode]
-> ModuleGraphNode
-> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
buildSingleModule forall a. Maybe a
Nothing) ModuleGraphNodeWithBootFile
-> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
buildOneLoopyModule) [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
      MVar (Maybe [HomeModInfo])
res_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
newEmptyMVar
      let loop_action :: RunMakeM [HomeModInfo]
loop_action = [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]
wait_deps [ResultVar (Maybe HomeModInfo)]
wait_modules
      let fanout :: Int -> ResultVar (Maybe HomeModInfo)
fanout Int
i = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> Int -> a
!! Int
i) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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.
      let update_module_pipeline :: (ModNodeKeyWithUid, Int) -> BuildM ()
update_module_pipeline (ModNodeKeyWithUid
m, Int
i) = NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()
setModulePipeline (ModNodeKeyWithUid -> NodeKey
NodeKey_Module ModNodeKeyWithUid
m) (FilePath -> SDoc
text FilePath
"T") (Int -> ResultVar (Maybe HomeModInfo)
fanout Int
i)

      let ms_i :: [(ModNodeKeyWithUid, Int)]
ms_i = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModSummary -> ModNodeKeyWithUid
msKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> Maybe ModSummary
moduleGraphNodeModSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id ModuleGraphNodeWithBootFile -> ModuleGraphNode
getNode) [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms) [Int
0..]
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModNodeKeyWithUid, Int) -> BuildM ()
update_module_pipeline [(ModNodeKeyWithUid, Int)]
ms_i
      return $ [MakeAction]
build_modules forall a. [a] -> [a] -> [a]
++ [forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction RunMakeM [HomeModInfo]
loop_action MVar (Maybe [HomeModInfo])
res_var]


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


upsweep
    :: Int -- ^ 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
    -> Maybe Messager
    -> M.Map ModNodeKeyWithUid HomeModInfo
    -> [BuildPlan]
    -> IO (SuccessFlag, HscEnv)
upsweep :: Int
-> HscEnv
-> Maybe ModIfaceCache
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, HscEnv)
upsweep Int
n_jobs HscEnv
hsc_env Maybe ModIfaceCache
hmi_cache Maybe Messager
mHscMessage Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan = do
    (Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipelines, IO [Maybe (Maybe HomeModInfo)]
collect_result) <- HomeUnitGraph
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
     (Maybe [ModuleGraphNode], [MakeAction],
      IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) Maybe ModIfaceCache
hmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan
    Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines Int
n_jobs HscEnv
hsc_env 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]
    let hsc_env' :: HscEnv
hsc_env' = [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv [HomeModInfo]
completed HscEnv
hsc_env

    -- Handle any cycle in the original compilation graph and return the result
    -- of the upsweep.
    case Maybe [ModuleGraphNode]
cycle of
        Just [ModuleGraphNode]
mss -> do
          let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
fatalErrorMsg Logger
logger ([ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss)
          return (SuccessFlag
Failed, HscEnv
hsc_env)
        Maybe [ModuleGraphNode]
Nothing  -> do
          let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
isJust [Maybe (Maybe HomeModInfo)]
res)
          forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
success_flag, HscEnv
hsc_env')

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

miKey :: ModIface -> ModNodeKeyWithUid
miKey :: ModIface -> ModNodeKeyWithUid
miKey ModIface
hmi = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModIface -> ModuleNameWithIsBoot
mi_mnwib ModIface
hmi) ((GenUnit UnitId -> UnitId
toUnitId forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
hmi)))

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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> GenUnit UnitId -> IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ 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
-> Maybe Linkable
-> IO HomeModInfo
compileOne' Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary
          Int
mod_index Int
nmods (HomeModInfo -> ModIface
hm_iface forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HomeModInfo
old_hmi) (Maybe HomeModInfo
old_hmi forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HomeModInfo -> Maybe Linkable
hm_linkable)

  -- 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 only happens with the
  -- bytecode backend, no need to guard against the backend type additionally.
  HscEnv -> Maybe Linkable -> IO ()
addSptEntries ((HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT (\HomePackageTable
hpt -> HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
summary) HomeModInfo
hmi) HscEnv
hsc_env)
                (HomeModInfo -> Maybe Linkable
hm_linkable 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
     | Just Linkable
linkable <- [Maybe Linkable
mlinkable]
     , Unlinked
unlinked <- Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
     , BCOs CompiledByteCode
_ [SptEntry]
spts <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Unlinked
unlinked
     , SptEntry
spt <- [SptEntry]
spts
     ]

{- Note [-fno-code mode]
~~~~~~~~~~~~~~~~~~~~~~~~
GHC offers the flag -fno-code for the purpose of parsing and typechecking a
program without generating object files. This is intended to be used by tooling
and IDEs to provide quick feedback on any parser or type errors as cheaply as
possible.

When GHC is invoked with -fno-code no object files or linked output will be
generated. As many errors and warnings as possible will be generated, as if
-fno-code had not been passed. The session DynFlags will have
backend == NoBackend.

-fwrite-interface
~~~~~~~~~~~~~~~~
Whether interface files are generated in -fno-code mode is controlled by the
-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
not also passed. Recompilation avoidance requires interface files, so passing
-fno-code without -fwrite-interface should be avoided. If -fno-code were
re-implemented today, -fwrite-interface would be discarded and it would be
considered always on; this behaviour is as it is for backwards compatibility.

================================================================
IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
================================================================

Template Haskell
~~~~~~~~~~~~~~~~
A module using template haskell may invoke an imported function from inside a
splice. This will cause the type-checker to attempt to execute that code, which
would fail if no object files had been generated. See #8025. To rectify this,
during the downsweep we patch the DynFlags in the ModSummary of any home module
that is imported by a module that uses template haskell, to generate object
code.

The flavour of generated object code is chosen by defaultObjectTarget for the
target platform. It would likely be faster to generate bytecode, but this is not
supported on all platforms(?Please Confirm?), and does not support the entirety
of GHC haskell. See #1257.

The object files (and interface files if -fwrite-interface is disabled) produced
for template haskell are written to temporary files.

Note that since template haskell can run arbitrary IO actions, -fno-code mode
is no more secure than running without it.

Potential TODOS:
~~~~~
* Remove -fwrite-interface and have interface files always written in -fno-code
  mode
* Both .o and .dyn_o files are generated for template haskell, but we only need
  .dyn_o. Fix it.
* In make mode, a message like
  Compiling A (A.hs, /tmp/ghc_123.o)
  is shown if downsweep enabled object code generation for A. Perhaps we should
  show "nothing" or "temporary object file" instead. Note that one
  can currently use -keep-tmp-files and inspect the generated file with the
  current behaviour.
* Offer a -no-codedir command line option, and write what were temporary
  object files there. This would speed up recompilation.
* Use existing object files (if they are up to date) instead of always
  generating temporary ones.
-}

-- 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 =
    -- stronglyConnCompG flips the original order, so if we reverse
    -- the summaries we get a stable topological sort.
  Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
drop_hs_boot_nodes (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
module_graph) Maybe HomeUnitModule
mb_root_mod

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
  = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> ModuleGraphNode
summaryNodeSummary) forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ ModNodeKeyWithUid -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
root_mod IsBootInterface
NotBoot) UnitId
uid
                     , Graph SummaryNode
graph forall node. Graph node -> node -> Bool
`hasVertexG` SummaryNode
node
                     = SummaryNode
node
                     | Bool
otherwise
                     = forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
ProgramError FilePath
"module does not exist")
            in forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (seq :: forall a b. a -> b -> b
seq SummaryNode
root (forall node. Graph node -> node -> [node]
reachableG 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 -> 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
<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
$c<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
fmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
$cfmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
Functor, Functor ModNodeMap
Foldable 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)
sequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
traverse :: 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)
Traversable, 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
product :: forall a. Num a => ModNodeMap a -> a
$cproduct :: forall a. Num a => ModNodeMap a -> a
sum :: forall a. Num a => ModNodeMap a -> a
$csum :: forall a. Num a => ModNodeMap a -> a
minimum :: forall a. Ord a => ModNodeMap a -> a
$cminimum :: forall a. Ord a => ModNodeMap a -> a
maximum :: forall a. Ord a => ModNodeMap a -> a
$cmaximum :: forall a. Ord a => ModNodeMap a -> a
elem :: forall a. Eq a => a -> ModNodeMap a -> Bool
$celem :: forall a. Eq a => a -> ModNodeMap a -> Bool
length :: forall a. ModNodeMap a -> Int
$clength :: forall a. ModNodeMap a -> Int
null :: forall a. ModNodeMap a -> Bool
$cnull :: forall a. ModNodeMap a -> Bool
toList :: forall a. ModNodeMap a -> [a]
$ctoList :: forall a. ModNodeMap a -> [a]
foldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
fold :: forall m. Monoid m => ModNodeMap m -> m
$cfold :: forall m. Monoid m => ModNodeMap m -> m
Foldable)

emptyModNodeMap :: ModNodeMap a
emptyModNodeMap :: forall a. ModNodeMap a
emptyModNodeMap = forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap 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) = forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (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) = 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) = 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 = forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (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) = forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (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 ModSummary] -> m ()
warnUnnecessarySourceImports :: forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
sccs = do
  DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
Opt_WarnUnusedImports DiagOpts
diag_opts) forall a b. (a -> b) -> a -> b
$ do
    let check :: [ModSummary] -> [MsgEnvelope GhcMessage]
check [ModSummary]
ms =
           let mods_in_this_cycle :: [ModuleName]
mods_in_this_cycle = forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
ms in
           [ GenLocated SrcSpan ModuleName -> MsgEnvelope GhcMessage
warn GenLocated SrcSpan ModuleName
i | ModSummary
m <- [ModSummary]
ms, GenLocated SrcSpan ModuleName
i <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
m,
                      forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
i 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts
                                                  SrcSpan
loc (ModuleName -> DriverMessage
DriverUnnecessarySourceImports ModuleName
mod)
    forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Bag a
listToBag (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ModSummary] -> [MsgEnvelope GhcMessage]
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs))


-- This caches the answer to the question, if we are in this unit, what does
-- an import of this module mean.
type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]

-----------------------------------------------------------------------------
--
-- | Downsweep (dependency analysis)
--
-- Chase downwards from the specified root set, returning summaries
-- for all home modules encountered.  Only follow source-import
-- links.
--
-- We pass in the previous collection of summaries, which is used as a
-- cache to avoid recalculating a module summary if the source is
-- unchanged.
--
-- The returned list of [ModSummary] nodes has one node for each home-package
-- module, plus one for any hs-boot files.  The imports of these nodes
-- are all there, including the imports of non-home-package modules.
downsweep :: HscEnv
          -> [ModSummary]
          -- ^ Old summaries
          -> [ModuleName]       -- Ignore dependencies on these; treat
                                -- them as if they were package modules
          -> Bool               -- True <=> allow multiple targets to have
                                --          the same module name; this is
                                --          very useful for ghc -M
          -> IO ([DriverMessages], [ModuleGraphNode])
                -- The non-error elements of the returned list all have distinct
                -- (Modules, IsBoot) identifiers, unless the Bool is true in
                -- which case there can be repeats
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep HscEnv
hsc_env [ModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots
   = do
       [Either (UnitId, DriverMessages) ModSummary]
rootSummaries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary [Target]
roots
       let ([(UnitId, DriverMessages)]
root_errs, [ModSummary]
rootSummariesOk) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (UnitId, DriverMessages) ModSummary]
rootSummaries -- #17549
           root_map :: DownsweepCache
root_map = [ModSummary] -> DownsweepCache
mkRootMap [ModSummary]
rootSummariesOk
       DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
       (Map NodeKey ModuleGraphNode
deps, Set (UnitId, UnitId)
pkg_deps, DownsweepCache
map0) <- [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
    DownsweepCache)
-> IO
     (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
rootSummariesOk (forall k a. Map k a
M.empty, forall a. Set a
Set.empty, DownsweepCache
root_map)
       let closure_errs :: [DriverMessages]
closure_errs = UnitEnv -> Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) (forall a. Set a -> [a]
Set.toList Set (UnitId, UnitId)
pkg_deps)
       let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
       let tmpfs :: TmpFs
tmpfs    = HscEnv -> TmpFs
hsc_tmpfs    HscEnv
hsc_env

       let downsweep_errs :: [DriverMessages]
downsweep_errs = forall a b. [Either a b] -> [a]
lefts forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems DownsweepCache
map0
           downsweep_nodes :: [ModuleGraphNode]
downsweep_nodes = forall k a. Map k a -> [a]
M.elems Map NodeKey ModuleGraphNode
deps

           ([DriverMessages]
other_errs, [ModuleGraphNode]
unit_nodes) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey (\[Either DriverMessages ModuleGraphNode]
nodes UnitId
uid HomeUnitEnv
hue -> [Either DriverMessages ModuleGraphNode]
nodes forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
downsweep_nodes UnitId
uid HomeUnitEnv
hue) [] (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env)
           all_nodes :: [ModuleGraphNode]
all_nodes = [ModuleGraphNode]
downsweep_nodes forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
unit_nodes
           all_errs :: [DriverMessages]
all_errs  = [DriverMessages]
all_root_errs forall a. [a] -> [a] -> [a]
++  [DriverMessages]
downsweep_errs forall a. [a] -> [a] -> [a]
++ [DriverMessages]
other_errs
           all_root_errs :: [DriverMessages]
all_root_errs =  [DriverMessages]
closure_errs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(UnitId, DriverMessages)]
root_errs

       -- if we have been passed -fno-code, we enable code generation
       -- for dependencies of modules that have -XTemplateHaskell,
       -- otherwise those modules will fail to compile.
       -- See Note [-fno-code mode] #8025
       [ModuleGraphNode]
th_enabled_nodes <- Logger
-> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO [ModuleGraphNode]
enableCodeGenForTH Logger
logger TmpFs
tmpfs UnitEnv
unit_env [ModuleGraphNode]
all_nodes
       if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DriverMessages]
all_root_errs
         then forall (m :: * -> *) a. Monad m => a -> m a
return ([DriverMessages]
all_errs, [ModuleGraphNode]
th_enabled_nodes)
         else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([DriverMessages]
all_root_errs, [])
     where
        -- Dependencies arising on a unit (backpack and module linking deps)
        unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
        unitModuleNodes :: [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue =
          let instantiation_nodes :: [ModuleGraphNode]
instantiation_nodes = UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes UnitId
uid (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue)
          in forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [ModuleGraphNode]
instantiation_nodes
              forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ([ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes ([ModuleGraphNode]
instantiation_nodes forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
summaries) UnitId
uid HomeUnitEnv
hue)

        calcDeps :: ModSummary
-> [(UnitId, PkgQual,
     GenWithIsBoot (GenLocated SrcSpan ModuleName))]
calcDeps ModSummary
ms =
          -- Add a dependency on the HsBoot file if it exists
          -- This gets passed to the loopImports function which just ignores it if it
          -- can't be found.
          [(ModSummary -> UnitId
ms_unitid ModSummary
ms, PkgQual
NoPkgQual, forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot) | IsBootInterface
NotBoot <- [ModSummary -> IsBootInterface
isBootSummary ModSummary
ms] ] forall a. [a] -> [a] -> [a]
++
          [(ModSummary -> UnitId
ms_unitid ModSummary
ms, PkgQual
b, GenWithIsBoot (GenLocated SrcSpan ModuleName)
c) | (PkgQual
b, GenWithIsBoot (GenLocated SrcSpan ModuleName)
c) <- ModSummary
-> [(PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
msDeps ModSummary
ms ]

        logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        roots :: [Target]
roots  = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env

        -- A cache from file paths to the already summarised modules. The same file
        -- can be used in multiple units so the map is also keyed by which unit the
        -- file was used in.
        -- Reuse these if we can because the most expensive part of downsweep is
        -- reading the headers.
        old_summary_map :: M.Map (UnitId, FilePath) ModSummary
        old_summary_map :: Map (UnitId, FilePath) ModSummary
old_summary_map = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((ModSummary -> UnitId
ms_unitid ModSummary
ms, ModSummary -> FilePath
msHsFilePath ModSummary
ms), ModSummary
ms) | ModSummary
ms <- [ModSummary]
old_summaries]

        getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
        getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary Target { targetId :: Target -> TargetId
targetId = TargetFile FilePath
file Maybe Phase
mb_phase
                              , targetContents :: Target -> Maybe (InputFileBuffer, UTCTime)
targetContents = Maybe (InputFileBuffer, UTCTime)
maybe_buf
                              , targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid
                              }
           = do let offset_file :: FilePath
offset_file = DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
file
                Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
offset_file
                if Bool
exists Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe (InputFileBuffer, UTCTime)
maybe_buf
                    then forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (UnitId
uid,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map FilePath
offset_file Maybe Phase
mb_phase
                                       Maybe (InputFileBuffer, UTCTime)
maybe_buf
                    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (UnitId
uid,) forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage
                                forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (FilePath -> DriverMessage
DriverFileNotFound FilePath
offset_file)
            where
              dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))
              home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
        getRootSummary Target { targetId :: Target -> TargetId
targetId = TargetModule ModuleName
modl
                              , targetContents :: Target -> Maybe (InputFileBuffer, UTCTime)
targetContents = Maybe (InputFileBuffer, UTCTime)
maybe_buf
                              , targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid
                              }
           = do SummariseResult
maybe_summary <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
NotBoot
                                           (forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) (UnitId -> PkgQual
ThisPkg (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit))
                                           Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
                case SummariseResult
maybe_summary of
                   FoundHome ModSummary
s  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ModSummary
s)
                   FoundHomeWithError (UnitId, DriverMessages)
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (UnitId, DriverMessages)
err)
                   SummariseResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (UnitId
uid, ModuleName -> DriverMessages
moduleNotFoundErr ModuleName
modl)
            where
              home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
        rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")

        -- In a root module, the filename is allowed to diverge from the module
        -- name, so we have to check that there aren't multiple root files
        -- defining the same module (otherwise the duplicates will be silently
        -- ignored, leading to confusing behaviour).
        checkDuplicates
          :: DownsweepCache
          -> IO ()
        checkDuplicates :: DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
           | Bool
allow_dup_roots = forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModSummary]]
dup_roots  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | Bool
otherwise       = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [ModSummary] -> IO ()
multiRootsErr (forall a. [a] -> a
head [[ModSummary]]
dup_roots)
           where
             dup_roots :: [[ModSummary]]        -- Each at least of length 2
             dup_roots :: [[ModSummary]]
dup_roots = forall a. (a -> Bool) -> [a] -> [a]
filterOut forall a. [a] -> Bool
isSingleton forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. [Either a b] -> [b]
rights (forall k a. Map k a -> [a]
M.elems DownsweepCache
root_map)

        -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
        loopSummaries :: [ModSummary]
              -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),
                    DownsweepCache)
              -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)
        loopSummaries :: [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
    DownsweepCache)
-> IO
     (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [] (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
done = forall (m :: * -> *) a. Monad m => a -> m a
return (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
done
        loopSummaries (ModSummary
ms:[ModSummary]
next) (Map NodeKey ModuleGraphNode
done, Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised)
          | Just {} <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
k Map NodeKey ModuleGraphNode
done
          = [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
    DownsweepCache)
-> IO
     (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
next (Map NodeKey ModuleGraphNode
done, Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised)
          -- Didn't work out what the imports mean yet, now do that.
          | Bool
otherwise = do
             ([NodeKey]
final_deps, Set (UnitId, UnitId)
pkgs1, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports (ModSummary
-> [(UnitId, PkgQual,
     GenWithIsBoot (GenLocated SrcSpan ModuleName))]
calcDeps ModSummary
ms) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
             -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
             ([NodeKey]
_, Set (UnitId, UnitId)
_, Map NodeKey ModuleGraphNode
done'', DownsweepCache
summarised'') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports (forall a. Maybe a -> [a]
maybeToList Maybe
  (UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
hs_file_for_boot) Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'
             [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
    DownsweepCache)
-> IO
     (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
next (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeKey
k ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
final_deps ModSummary
ms) Map NodeKey ModuleGraphNode
done'', Set (UnitId, UnitId)
pkgs1 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised'')
          where
            k :: NodeKey
k = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms)

            hs_file_for_boot :: Maybe
  (UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
hs_file_for_boot
              | HscSource
HsBootFile <- ModSummary -> HscSource
ms_hsc_src ModSummary
ms = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ((ModSummary -> UnitId
ms_unitid ModSummary
ms), PkgQual
NoPkgQual, (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
NotBoot))
              | Bool
otherwise = forall a. Maybe a
Nothing


        -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
        -- a new module by doing this.
        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
                        -- Work list: process these modules
             -> M.Map NodeKey ModuleGraphNode
             -> DownsweepCache
                        -- Visited set; the range is a list because
                        -- the roots can have the same module names
                        -- if allow_dup_roots is True
             -> IO ([NodeKey], Set.Set (UnitId, UnitId),

                  M.Map NodeKey ModuleGraphNode, DownsweepCache)
                        -- The result is the completed NodeMap
        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [] Map NodeKey ModuleGraphNode
done DownsweepCache
summarised = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Set a
Set.empty, Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
        loopImports ((UnitId
home_uid,PkgQual
mb_pkg, GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib) : [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
          | Just [Either DriverMessages ModSummary]
summs <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key DownsweepCache
summarised
          = case [Either DriverMessages ModSummary]
summs of
              [Right ModSummary
ms] -> do
                let nk :: NodeKey
nk = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms)
                ([NodeKey]
rest, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
                forall (m :: * -> *) a. Monad m => a -> m a
return (NodeKey
nkforall a. a -> [a] -> [a]
: [NodeKey]
rest, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done')
              [Left DriverMessages
_err] ->
                [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
              [Either DriverMessages ModSummary]
_errs ->  do
                [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
          | Bool
otherwise
          = do
               SummariseResult
mb_s <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map
                                       IsBootInterface
is_boot GenLocated SrcSpan ModuleName
wanted_mod PkgQual
mb_pkg
                                       forall a. Maybe a
Nothing [ModuleName]
excl_mods
               case SummariseResult
mb_s of
                   SummariseResult
NotThere -> [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
                   External UnitId
uid -> do
                    ([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
                    forall (m :: * -> *) a. Monad m => a -> m a
return ([NodeKey]
other_deps, forall a. Ord a => a -> Set a -> Set a
Set.insert (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit, UnitId
uid) Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
                   FoundInstantiation InstantiatedUnit
iud -> do
                    ([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
                    forall (m :: * -> *) a. Monad m => a -> m a
return (InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
iud forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
                   FoundHomeWithError (UnitId
_uid, DriverMessages
e) ->  [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [(forall a b. a -> Either a b
Left DriverMessages
e)] DownsweepCache
summarised)
                   FoundHome ModSummary
s -> do
                     (Map NodeKey ModuleGraphNode
done', Set (UnitId, UnitId)
pkgs1, DownsweepCache
summarised') <-
                       [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
    DownsweepCache)
-> IO
     (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary
s] (Map NodeKey ModuleGraphNode
done, forall a. Set a
Set.empty, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [forall a b. b -> Either a b
Right ModSummary
s] DownsweepCache
summarised)
                     ([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs2, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised) <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
     ([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
      DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'

                     -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
                     forall (m :: * -> *) a. Monad m => a -> m a
return (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
s) forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs1 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (UnitId, UnitId)
pkgs2, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised)
          where
            cache_key :: (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key = (UnitId
home_uid, PkgQual
mb_pkg, forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib)
            home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
home_uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
            GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = L SrcSpan
loc ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot } = GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib
            wanted_mod :: GenLocated SrcSpan ModuleName
wanted_mod = forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ModuleName
mod

-- This function checks then important property that if both p and q are home units
-- then any dependency of p, which transitively depends on q is also a home unit.
checkHomeUnitsClosed ::  UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
-- Fast path, trivially closed.
checkHomeUnitsClosed :: UnitEnv -> Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed UnitEnv
ue Set UnitId
home_id_set [(UnitId, UnitId)]
home_imp_ids
  | forall a. Set a -> Int
Set.size Set UnitId
home_id_set forall a. Eq a => a -> a -> Bool
== Int
1 = []
  | Bool
otherwise =
  let res :: Set UnitId
res = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (UnitId, UnitId) -> Set UnitId
loop [(UnitId, UnitId)]
home_imp_ids
  -- Now check whether everything which transitively depends on a home_unit is actually a home_unit
  -- These units are the ones which we need to load as home packages but failed to do for some reason,
  -- it's a bug in the tool invoking GHC.
      bad_unit_ids :: Set UnitId
bad_unit_ids = forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set UnitId
res Set UnitId
home_id_set
  in if forall a. Set a -> Bool
Set.null Set UnitId
bad_unit_ids
        then []
        else [forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
rootLoc forall a b. (a -> b) -> a -> b
$ [UnitId] -> DriverMessage
DriverHomePackagesNotClosed (forall a. Set a -> [a]
Set.toList Set UnitId
bad_unit_ids)]

  where
    rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")
    -- TODO: This could repeat quite a bit of work but I struggled to write this function.
    -- Which units transitively depend on a home unit
    loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit
    loop :: (UnitId, UnitId) -> Set UnitId
loop (UnitId
from_uid, UnitId
uid) =
      let us :: HomeUnitEnv
us = HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
from_uid UnitEnv
ue in
      let um :: UnitInfoMap
um = UnitState -> UnitInfoMap
unitInfoMap (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
us) in
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid UnitInfoMap
um of
        Maybe UnitInfo
Nothing -> forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"uid not found" (forall a. Outputable a => a -> SDoc
ppr UnitId
uid)
        Just UnitInfo
ui ->
          let depends :: [UnitId]
depends = forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
ui
              home_depends :: Set UnitId
home_depends = forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
depends forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set UnitId
home_id_set
              other_depends :: Set UnitId
other_depends = forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
depends forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set UnitId
home_id_set
          in
            -- Case 1: The unit directly depends on a home_id
            if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set UnitId
home_depends)
              then
                let res :: Set UnitId
res = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((UnitId, UnitId) -> Set UnitId
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId
from_uid,)) Set UnitId
other_depends
                in forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
res
             -- Case 2: Check the rest of the dependencies, and then see if any of them depended on
              else
                let res :: Set UnitId
res = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((UnitId, UnitId) -> Set UnitId
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId
from_uid,)) Set UnitId
other_depends
                in
                  if Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set UnitId
res)
                    then forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
res
                    else Set UnitId
res

-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
-- the specified target, disable optimization and change the .hi
-- and .o file locations to be temporary files.
-- See Note [-fno-code mode]
enableCodeGenForTH
  :: Logger
  -> TmpFs
  -> UnitEnv
  -> [ModuleGraphNode]
  -> IO [ModuleGraphNode]
enableCodeGenForTH :: Logger
-> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO [ModuleGraphNode]
enableCodeGenForTH Logger
logger TmpFs
tmpfs UnitEnv
unit_env =
  Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenWhen Logger
logger TmpFs
tmpfs TempFileLifetime
TFL_CurrentModule TempFileLifetime
TFL_GhcSession UnitEnv
unit_env

-- | Helper used to implement 'enableCodeGenForTH'.
-- In particular, this enables
-- unoptimized code generation for all modules that meet some
-- condition (first parameter), or are dependencies of those
-- modules. The second parameter is a condition to check before
-- marking modules for code generation.
enableCodeGenWhen
  :: Logger
  -> TmpFs
  -> TempFileLifetime
  -> TempFileLifetime
  -> UnitEnv
  -> [ModuleGraphNode]
  -> IO [ModuleGraphNode]
enableCodeGenWhen :: Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenWhen Logger
logger TmpFs
tmpfs TempFileLifetime
staticLife TempFileLifetime
dynLife UnitEnv
unit_env [ModuleGraphNode]
mod_graph =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen [ModuleGraphNode]
mod_graph
  where
    defaultBackendOf :: ModSummary -> Backend
defaultBackendOf ModSummary
ms = Platform -> Backend
platformDefaultBackend (DynFlags -> Platform
targetPlatform forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitId -> UnitEnv -> DynFlags
ue_unitFlags (ModSummary -> UnitId
ms_unitid ModSummary
ms) UnitEnv
unit_env)
    enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
    enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen n :: ModuleGraphNode
n@(ModuleNode [NodeKey]
deps ModSummary
ms)
      | ModSummary
        { ms_location :: ModSummary -> ModLocation
ms_location = ModLocation
ms_location
        , ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
HsSrcFile
        , ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags
        } <- ModSummary
ms
      , ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set NodeKey
needs_codegen_set =
      if | ModSummary -> Bool
nocode_enable ModSummary
ms -> do
               let new_temp_file :: FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file FilePath
suf FilePath
dynsuf = do
                     FilePath
tn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
staticLife FilePath
suf
                     let dyn_tn :: FilePath
dyn_tn = FilePath
tn FilePath -> FilePath -> FilePath
-<.> FilePath
dynsuf
                     TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
dynLife [FilePath
dyn_tn]
                     return (FilePath
tn, FilePath
dyn_tn)
                 -- We don't want to create .o or .hi files unless we have been asked
                 -- to by the user. But we need them, so we patch their locations in
                 -- the ModSummary with temporary files.
                 --
               ((FilePath
hi_file, FilePath
dyn_hi_file), (FilePath
o_file, FilePath
dyn_o_file)) <-
                 -- If ``-fwrite-interface` is specified, then the .o and .hi files
                 -- are written into `-odir` and `-hidir` respectively.  #16670
                 if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
                   then forall (m :: * -> *) a. Monad m => a -> m a
return ((ModLocation -> FilePath
ml_hi_file ModLocation
ms_location, ModLocation -> FilePath
ml_dyn_hi_file ModLocation
ms_location)
                               , (ModLocation -> FilePath
ml_obj_file ModLocation
ms_location, ModLocation -> FilePath
ml_dyn_obj_file ModLocation
ms_location))
                   else (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file (DynFlags -> FilePath
hiSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynHiSuf_ DynFlags
dflags))
                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file (DynFlags -> FilePath
objectSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynObjectSuf_ DynFlags
dflags))
               let ms' :: ModSummary
ms' = ModSummary
ms
                     { ms_location :: ModLocation
ms_location =
                         ModLocation
ms_location { ml_hi_file :: FilePath
ml_hi_file = FilePath
hi_file
                                     , ml_obj_file :: FilePath
ml_obj_file = FilePath
o_file
                                     , ml_dyn_hi_file :: FilePath
ml_dyn_hi_file = FilePath
dyn_hi_file
                                     , ml_dyn_obj_file :: FilePath
ml_dyn_obj_file = FilePath
dyn_o_file }
                     , ms_hspp_opts :: DynFlags
ms_hspp_opts = Int -> DynFlags -> DynFlags
updOptLevel Int
0 forall a b. (a -> b) -> a -> b
$ DynFlags
dflags {backend :: Backend
backend = ModSummary -> Backend
defaultBackendOf ModSummary
ms}
                     }
               -- Recursive call to catch the other cases
               ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
         | ModSummary -> Bool
dynamic_too_enable ModSummary
ms -> do
               let ms' :: ModSummary
ms' = ModSummary
ms
                     { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> GeneralFlag -> DynFlags
gopt_set (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) GeneralFlag
Opt_BuildDynamicToo
                     }
               -- Recursive call to catch the other cases
               ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
         | ModSummary -> Bool
ext_interp_enable ModSummary
ms -> do
               let ms' :: ModSummary
ms' = ModSummary
ms
                     { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> GeneralFlag -> DynFlags
gopt_set (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) GeneralFlag
Opt_ExternalInterpreter
                     }
               -- Recursive call to catch the other cases
               ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')

         | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraphNode
n

    enable_code_gen ModuleGraphNode
ms = forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraphNode
ms

    nocode_enable :: ModSummary -> Bool
nocode_enable ms :: ModSummary
ms@(ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
      DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
== Backend
NoBackend Bool -> Bool -> Bool
&&
      -- Don't enable codegen for TH on indefinite packages; we
      -- can't compile anything anyway! See #16219.
      forall u. GenHomeUnit u -> Bool
isHomeUnitDefinite (UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit (ModSummary -> UnitId
ms_unitid ModSummary
ms) UnitEnv
unit_env)

    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
    -- the linker can correctly load the object files.  This isn't necessary
    -- when using -fexternal-interpreter.
    dynamic_too_enable :: ModSummary -> Bool
dynamic_too_enable ModSummary
ms
      = Bool
hostIsDynamic Bool -> Bool -> Bool
&& Bool
internalInterpreter Bool -> Bool -> Bool
&&
            Bool -> Bool
not Bool
isDynWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isProfWay Bool -> Bool -> Bool
&&  Bool -> Bool
not Bool
dyn_too_enabled
      where
       lcl_dflags :: DynFlags
lcl_dflags   = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
       internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
lcl_dflags)
       dyn_too_enabled :: Bool
dyn_too_enabled =  (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
lcl_dflags)
       isDynWay :: Bool
isDynWay    = Ways -> Way -> Bool
hasWay (DynFlags -> Ways
ways DynFlags
lcl_dflags) Way
WayDyn
       isProfWay :: Bool
isProfWay   = Ways -> Way -> Bool
hasWay (DynFlags -> Ways
ways DynFlags
lcl_dflags) Way
WayProf

    -- #16331 - when no "internal interpreter" is available but we
    -- need to process some TemplateHaskell or QuasiQuotes, we automatically
    -- turn on -fexternal-interpreter.
    ext_interp_enable :: ModSummary -> Bool
ext_interp_enable ModSummary
ms = Bool -> Bool
not Bool
ghciSupported Bool -> Bool -> Bool
&& Bool
internalInterpreter
      where
       lcl_dflags :: DynFlags
lcl_dflags   = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
       internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
lcl_dflags)




    (Graph SummaryNode
mg, NodeKey -> Maybe SummaryNode
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False [ModuleGraphNode]
mod_graph
    needs_codegen_set :: Set NodeKey
needs_codegen_set = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ModuleGraphNode -> NodeKey
mkNodeKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key payload. Node key payload -> payload
node_payload) forall a b. (a -> b) -> a -> b
$ forall node. Graph node -> [node] -> [node]
reachablesG Graph SummaryNode
mg (forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"needs_th" forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node) [NodeKey]
has_th_set)


    has_th_set :: [NodeKey]
has_th_set =
      [ ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn
      | mn :: ModuleGraphNode
mn@(ModuleNode [NodeKey]
_ ModSummary
ms) <- [ModuleGraphNode]
mod_graph
      , ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
      ]

-- | Populate the Downsweep cache with the root modules.
mkRootMap
  :: [ModSummary]
  -> DownsweepCache
mkRootMap :: [ModSummary] -> DownsweepCache
mkRootMap [ModSummary]
summaries = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> [a] -> [a]
(++))
  [ ((ModSummary -> UnitId
ms_unitid ModSummary
s, PkgQual
NoPkgQual, ModSummary -> ModuleNameWithIsBoot
ms_mnwib ModSummary
s), [forall a b. b -> Either a b
Right ModSummary
s]) | ModSummary
s <- [ModSummary]
summaries ]

-----------------------------------------------------------------------------
-- Summarising modules

-- We have two types of summarisation:
--
--    * Summarise a file.  This is used for the root module(s) passed to
--      cmLoadModules.  The file is read, and used to determine the root
--      module name.  The module name may differ from the filename.
--
--    * Summarise a module.  We are given a module name, and must provide
--      a summary.  The finder is used to locate the file in which the module
--      resides.

summariseFile
        :: HscEnv
        -> HomeUnit
        -> M.Map (UnitId, FilePath) ModSummary    -- old summaries
        -> FilePath                     -- source file name
        -> Maybe Phase                  -- start phase
        -> Maybe (StringBuffer,UTCTime)
        -> IO (Either DriverMessages ModSummary)

summariseFile :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile HscEnv
hsc_env' HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf
        -- we can use a cached summary if one is available and the
        -- source file hasn't changed,
   | Just ModSummary
old_summary <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit, FilePath
src_fn) Map (UnitId, FilePath) ModSummary
old_summaries
   = do
        let location :: ModLocation
location = ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ModSummary
old_summary

        Fingerprint
src_hash <- IO Fingerprint
get_src_hash
                -- The file exists; we checked in getRootSummary above.
                -- If it gets removed subsequently, then this
                -- getFileHash may fail, but that's the right
                -- behaviour.

                -- return the cached summary if the source didn't change
        forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash
            HscEnv
hsc_env (FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn)
            ModSummary
old_summary ModLocation
location Fingerprint
src_hash

   | Bool
otherwise
   = do Fingerprint
src_hash <- IO Fingerprint
get_src_hash
        FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn Fingerprint
src_hash
  where
    -- change the main active unit so all operations happen relative to the given unit
    hsc_env :: HscEnv
hsc_env = HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'
    -- src_fn does not necessarily exist on the filesystem, so we need to
    -- check what kind of target we are dealing with
    get_src_hash :: IO Fingerprint
get_src_hash = case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
                      Just (InputFileBuffer
buf,UTCTime
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InputFileBuffer -> Fingerprint
fingerprintStringBuffer InputFileBuffer
buf
                      Maybe (InputFileBuffer, UTCTime)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Fingerprint
getFileHash FilePath
src_fn

    new_summary :: FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn Fingerprint
src_hash = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
        preimps :: PreprocessedImports
preimps@PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
DynFlags
InputFileBuffer
SrcSpan
ModuleName
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_ghc_prim_import :: Bool
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}
            <- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf

        let fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)

        -- Make a ModLocation for this file
        let location :: ModLocation
location = FinderOpts -> ModuleName -> FilePath -> ModLocation
mkHomeModLocation FinderOpts
fopts ModuleName
pi_mod_name FilePath
src_fn

        -- Tell the Finder cache where it is, so that subsequent calls
        -- to findModule will find it, even if it's not on any search path
        Module
mod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
          let fc :: FinderCache
fc        = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
          FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder FinderCache
fc HomeUnit
home_unit ModuleName
pi_mod_name ModLocation
location

        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
            { nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
            , nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
            , nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
NotBoot
            , nms_hsc_src :: HscSource
nms_hsc_src =
                if FilePath -> Bool
isHaskellSigFilename FilePath
src_fn
                   then HscSource
HsigFile
                   else HscSource
HsSrcFile
            , nms_location :: ModLocation
nms_location = ModLocation
location
            , nms_mod :: Module
nms_mod = Module
mod
            , nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
            }

checkSummaryHash
    :: HscEnv
    -> (Fingerprint -> IO (Either e ModSummary))
    -> ModSummary -> ModLocation -> Fingerprint
    -> IO (Either e ModSummary)
checkSummaryHash :: forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash
  HscEnv
hsc_env Fingerprint -> IO (Either e ModSummary)
new_summary
  ModSummary
old_summary
  ModLocation
location Fingerprint
src_hash
  | ModSummary -> Fingerprint
ms_hs_hash ModSummary
old_summary forall a. Eq a => a -> a -> Bool
== Fingerprint
src_hash Bool -> Bool -> Bool
&&
      Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = do
           -- update the object-file timestamp
           Maybe UTCTime
obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
location)

           -- We have to repopulate the Finder's cache for file targets
           -- because the file might not even be on the regular search path
           -- and it was likely flushed in depanal. This is not technically
           -- needed when we're called from sumariseModule but it shouldn't
           -- hurt.
           -- Also, only add to finder cache for non-boot modules as the finder cache
           -- makes sure to add a boot suffix for boot files.
           ()
_ <- do
              let fc :: FinderCache
fc        = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
              case ModSummary -> HscSource
ms_hsc_src ModSummary
old_summary of
                HscSource
HsSrcFile -> FinderCache -> Module -> ModLocation -> IO ()
addModuleToFinder FinderCache
fc (ModSummary -> Module
ms_mod ModSummary
old_summary) ModLocation
location
                HscSource
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

           Maybe UTCTime
hi_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
           Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)

           return $ forall a b. b -> Either a b
Right
             ( ModSummary
old_summary
                     { ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
                     , ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
                     , ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
                     }
             )

   | Bool
otherwise =
           -- source changed: re-summarise.
           Fingerprint -> IO (Either e ModSummary)
new_summary Fingerprint
src_hash

data SummariseResult =
        FoundInstantiation InstantiatedUnit
      | FoundHomeWithError (UnitId, DriverMessages)
      | FoundHome ModSummary
      | External UnitId
      | NotThere

-- Summarise a module, and pick up source and timestamp.
summariseModule
          :: HscEnv
          -> HomeUnit
          -> M.Map (UnitId, FilePath) ModSummary
          -- ^ Map of old summaries
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Located ModuleName -- Imported module to be summarised
          -> PkgQual
          -> Maybe (StringBuffer, UTCTime)
          -> [ModuleName]               -- Modules to exclude
          -> IO SummariseResult


summariseModule :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env' HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
is_boot (L SrcSpan
_ ModuleName
wanted_mod) PkgQual
mb_pkg
                Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
  | ModuleName
wanted_mod forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
excl_mods
  = forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
  | Bool
otherwise  = IO SummariseResult
find_it
  where
    -- Temporarily change the currently active home unit so all operations
    -- happen relative to it
    hsc_env :: HscEnv
hsc_env   = HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'
    dflags :: DynFlags
dflags    = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

    find_it :: IO SummariseResult

    find_it :: IO SummariseResult
find_it = do
        FindResult
found <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
wanted_mod PkgQual
mb_pkg
        case FindResult
found of
             Found ModLocation
location Module
mod
                | forall a. Maybe a -> Bool
isJust (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location) ->
                        -- Home package
                         ModLocation -> Module -> IO SummariseResult
just_found ModLocation
location Module
mod
                | VirtUnit InstantiatedUnit
iud <- forall unit. GenModule unit -> unit
moduleUnit Module
mod
                , Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod)
                  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> SummariseResult
FoundInstantiation InstantiatedUnit
iud
                | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UnitId -> SummariseResult
External (Module -> UnitId
moduleUnitId Module
mod)
             FindResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
                        -- Not found
                        -- (If it is TRULY not found at all, we'll
                        -- error when we actually try to compile)

    just_found :: ModLocation -> Module -> IO SummariseResult
just_found ModLocation
location Module
mod = do
                -- Adjust location to point to the hs-boot source file,
                -- hi file, object file, when is_boot says so
        let location' :: ModLocation
location' = case IsBootInterface
is_boot of
              IsBootInterface
IsBoot -> ModLocation -> ModLocation
addBootSuffixLocn ModLocation
location
              IsBootInterface
NotBoot -> ModLocation
location
            src_fn :: FilePath
src_fn = forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"summarise2" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location')

                -- Check that it exists
                -- It might have been deleted since the Finder last found it
        Maybe Fingerprint
maybe_h <- FilePath -> IO (Maybe Fingerprint)
fileHashIfExists FilePath
src_fn
        case Maybe Fingerprint
maybe_h of
          -- This situation can also happen if we have found the .hs file but the
          -- .hs-boot file doesn't exist.
          Maybe Fingerprint
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
          Just Fingerprint
h  -> do
            Either DriverMessages ModSummary
fresult <- ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary_cache_check ModLocation
location' Module
mod FilePath
src_fn Fingerprint
h
            return $ case Either DriverMessages ModSummary
fresult of
              Left DriverMessages
err -> (UnitId, DriverMessages) -> SummariseResult
FoundHomeWithError (Module -> UnitId
moduleUnitId Module
mod, DriverMessages
err)
              Right ModSummary
ms -> ModSummary -> SummariseResult
FoundHome ModSummary
ms

    new_summary_cache_check :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary_cache_check ModLocation
loc Module
mod FilePath
src_fn Fingerprint
h
      | Just ModSummary
old_summary <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((GenUnit UnitId -> UnitId
toUnitId (forall unit. GenModule unit -> unit
moduleUnit Module
mod), FilePath
src_fn)) Map (UnitId, FilePath) ModSummary
old_summary_map =

         -- check the hash on the source file, and
         -- return the cached summary if it hasn't changed.  If the
         -- file has changed then need to resummarise.
        case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
           Just (InputFileBuffer
buf,UTCTime
_) ->
               forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash HscEnv
hsc_env (ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn) ModSummary
old_summary ModLocation
loc (InputFileBuffer -> Fingerprint
fingerprintStringBuffer InputFileBuffer
buf)
           Maybe (InputFileBuffer, UTCTime)
Nothing    ->
               forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash HscEnv
hsc_env (ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn) ModSummary
old_summary ModLocation
loc Fingerprint
h
      | Bool
otherwise = ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn Fingerprint
h

    new_summary :: ModLocation
                  -> Module
                  -> FilePath
                  -> Fingerprint
                  -> IO (Either DriverMessages ModSummary)
    new_summary :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
location Module
mod FilePath
src_fn Fingerprint
src_hash
      = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
        preimps :: PreprocessedImports
preimps@PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
DynFlags
InputFileBuffer
SrcSpan
ModuleName
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_ghc_prim_import :: Bool
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..}
            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
            -- See multiHomeUnits_cpp2 test
            <- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
mod) HscEnv
hsc_env) FilePath
src_fn forall a. Maybe a
Nothing Maybe (InputFileBuffer, UTCTime)
maybe_buf

        -- NB: Despite the fact that is_boot is a top-level parameter, we
        -- don't actually know coming into this function what the HscSource
        -- of the module in question is.  This is because we may be processing
        -- this module because another module in the graph imported it: in this
        -- case, we know if it's a boot or not because of the {-# SOURCE #-}
        -- annotation, but we don't know if it's a signature or a regular
        -- module until we actually look it up on the filesystem.
        let hsc_src :: HscSource
hsc_src
              | IsBootInterface
is_boot forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot = HscSource
HsBootFile
              | FilePath -> Bool
isHaskellSigFilename FilePath
src_fn = HscSource
HsigFile
              | Bool
otherwise = HscSource
HsSrcFile

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
pi_mod_name forall a. Eq a => a -> a -> Bool
/= ModuleName
wanted_mod) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
                       forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> DriverMessage
DriverFileModuleNameMismatch ModuleName
pi_mod_name ModuleName
wanted_mod

        let instantiations :: GenInstantiations UnitId
instantiations = forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name GenInstantiations UnitId
instantiations)) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
                   forall a b. (a -> b) -> a -> b
$ ModuleName
-> BuildingCabalPackage
-> GenInstantiations UnitId
-> DriverMessage
DriverUnexpectedSignature ModuleName
pi_mod_name (DynFlags -> BuildingCabalPackage
checkBuildingCabalPackage DynFlags
dflags) GenInstantiations UnitId
instantiations

        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
            { nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
            , nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
            , nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
is_boot
            , nms_hsc_src :: HscSource
nms_hsc_src = HscSource
hsc_src
            , nms_location :: ModLocation
nms_location = ModLocation
location
            , nms_mod :: Module
nms_mod = Module
mod
            , nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
            }

-- | Convenience named arguments for 'makeNewModSummary' only used to make
-- code more readable, not exported.
data MakeNewModSummary
  = MakeNewModSummary
      { MakeNewModSummary -> FilePath
nms_src_fn :: FilePath
      , MakeNewModSummary -> Fingerprint
nms_src_hash :: Fingerprint
      , MakeNewModSummary -> IsBootInterface
nms_is_boot :: IsBootInterface
      , MakeNewModSummary -> HscSource
nms_hsc_src :: HscSource
      , MakeNewModSummary -> ModLocation
nms_location :: ModLocation
      , MakeNewModSummary -> Module
nms_mod :: Module
      , MakeNewModSummary -> PreprocessedImports
nms_preimps :: PreprocessedImports
      }

makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env MakeNewModSummary{FilePath
Fingerprint
HscSource
ModLocation
IsBootInterface
Module
PreprocessedImports
nms_preimps :: PreprocessedImports
nms_mod :: Module
nms_location :: ModLocation
nms_hsc_src :: HscSource
nms_is_boot :: IsBootInterface
nms_src_hash :: Fingerprint
nms_src_fn :: FilePath
nms_preimps :: MakeNewModSummary -> PreprocessedImports
nms_mod :: MakeNewModSummary -> Module
nms_location :: MakeNewModSummary -> ModLocation
nms_hsc_src :: MakeNewModSummary -> HscSource
nms_is_boot :: MakeNewModSummary -> IsBootInterface
nms_src_hash :: MakeNewModSummary -> Fingerprint
nms_src_fn :: MakeNewModSummary -> FilePath
..} = do
  let PreprocessedImports{Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
DynFlags
InputFileBuffer
SrcSpan
ModuleName
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_ghc_prim_import :: Bool
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..} = PreprocessedImports
nms_preimps
  Maybe UTCTime
obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
nms_location)
  Maybe UTCTime
dyn_obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_dyn_obj_file ModLocation
nms_location)
  Maybe UTCTime
hi_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
nms_location)
  Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
nms_location)

  [ModuleName]
extra_sig_imports <- HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
nms_hsc_src ModuleName
pi_mod_name
  ([ModuleName]
implicit_sigs, [InstantiatedUnit]
_inst_deps) <- HscEnv
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
nms_mod) HscEnv
hsc_env) [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps

  return $
        ModSummary
        { ms_mod :: Module
ms_mod = Module
nms_mod
        , ms_hsc_src :: HscSource
ms_hsc_src = HscSource
nms_hsc_src
        , ms_location :: ModLocation
ms_location = ModLocation
nms_location
        , ms_hspp_file :: FilePath
ms_hspp_file = FilePath
pi_hspp_fn
        , ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
pi_local_dflags
        , ms_hspp_buf :: Maybe InputFileBuffer
ms_hspp_buf  = forall a. a -> Maybe a
Just InputFileBuffer
pi_hspp_buf
        , ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = forall a. Maybe a
Nothing
        , ms_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps = [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps
        , ms_ghc_prim_import :: Bool
ms_ghc_prim_import = Bool
pi_ghc_prim_import
        , ms_textual_imps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps =
            ((,) PkgQual
NoPkgQual forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
extra_sig_imports) forall a. [a] -> [a] -> [a]
++
            ((,) PkgQual
NoPkgQual forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs) forall a. [a] -> [a] -> [a]
++
            [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps
        , ms_hs_hash :: Fingerprint
ms_hs_hash = Fingerprint
nms_src_hash
        , ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
        , ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
        , ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
        , ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date = Maybe UTCTime
dyn_obj_timestamp
        }

data PreprocessedImports
  = PreprocessedImports
      { PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
      , PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps  :: [(PkgQual, Located ModuleName)]
      , PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps  :: [(PkgQual, Located ModuleName)]
      , PreprocessedImports -> Bool
pi_ghc_prim_import :: Bool
      , PreprocessedImports -> FilePath
pi_hspp_fn  :: FilePath
      , PreprocessedImports -> InputFileBuffer
pi_hspp_buf :: StringBuffer
      , PreprocessedImports -> SrcSpan
pi_mod_name_loc :: SrcSpan
      , PreprocessedImports -> ModuleName
pi_mod_name :: ModuleName
      }

-- Preprocess the source file and get its imports
-- The pi_local_dflags contains the OPTIONS pragmas
getPreprocessedImports
    :: HscEnv
    -> FilePath
    -> Maybe Phase
    -> Maybe (StringBuffer, UTCTime)
    -- ^ optional source code buffer and modification time
    -> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports :: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf = do
  (DynFlags
pi_local_dflags, FilePath
pi_hspp_fn)
      <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either DriverMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
src_fn (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (InputFileBuffer, UTCTime)
maybe_buf) Maybe Phase
mb_phase
  InputFileBuffer
pi_hspp_buf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
pi_hspp_fn
  ([(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps', [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps', Bool
pi_ghc_prim_import, L SrcSpan
pi_mod_name_loc ModuleName
pi_mod_name)
      <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
          let imp_prelude :: Bool
imp_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
pi_local_dflags
              popts :: ParserOpts
popts = DynFlags -> ParserOpts
initParserOpts DynFlags
pi_local_dflags
          Either
  (Messages PsMessage)
  ([(RawPkgQual, GenLocated SrcSpan ModuleName)],
   [(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
   GenLocated SrcSpan ModuleName)
mimps <- ParserOpts
-> Bool
-> InputFileBuffer
-> FilePath
-> FilePath
-> IO
     (Either
        (Messages PsMessage)
        ([(RawPkgQual, GenLocated SrcSpan ModuleName)],
         [(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
         GenLocated SrcSpan ModuleName))
getImports ParserOpts
popts Bool
imp_prelude InputFileBuffer
pi_hspp_buf FilePath
pi_hspp_fn FilePath
src_fn
          return (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Messages e -> Bag (MsgEnvelope e)
getMessages) Either
  (Messages PsMessage)
  ([(RawPkgQual, GenLocated SrcSpan ModuleName)],
   [(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
   GenLocated SrcSpan ModuleName)
mimps)
  let rn_pkg_qual :: ModuleName -> RawPkgQual -> PkgQual
rn_pkg_qual = UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
  let rn_imps :: [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RawPkgQual
pk, lmn :: GenLocated SrcSpan ModuleName
lmn@(L SrcSpan
_ ModuleName
mn)) -> (ModuleName -> RawPkgQual -> PkgQual
rn_pkg_qual ModuleName
mn RawPkgQual
pk, GenLocated SrcSpan ModuleName
lmn))
  let pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps = [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps'
  let pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps = [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps'
  forall (m :: * -> *) a. Monad m => a -> m a
return PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
DynFlags
InputFileBuffer
SrcSpan
ModuleName
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_ghc_prim_import :: Bool
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_local_dflags :: DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_ghc_prim_import :: Bool
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}


-----------------------------------------------------------------------------
--                      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 <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  if Bool -> Bool
not 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
    IORef [IO ()]
errors <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
    IORef [IO ()]
fatals <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
    Logger
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 DiagnosticReason
_reason
              -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
warnings forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
            MCDiagnostic Severity
SevError DiagnosticReason
_reason
              -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
errors   forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
            MessageClass
MCFatal
              -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
fatals   forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
            MessageClass
_ -> IO ()
action

        printDeferredDiagnostics :: m ()
printDeferredDiagnostics = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          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] 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.
            [IO ()]
actions <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
ref forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> ([], [IO ()]
i)
            forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [IO ()]
actions

    forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
      (forall (m :: * -> *).
GhcMonad m =>
((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
 -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
pushLogHookM (forall a b. a -> b -> a
const LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
deferDiagnostics))
      (\()
_ -> forall (m :: * -> *). GhcMonad m => m ()
popLogHookM 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
  = forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
    HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
wanted_mod FindResult
err

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

moduleNotFoundErr :: ModuleName -> DriverMessages
moduleNotFoundErr :: ModuleName -> DriverMessages
moduleNotFoundErr ModuleName
mod = forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverModuleNotFound ModuleName
mod)

multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = forall a. FilePath -> a
panic FilePath
"multiRootsErr"
multiRootsErr summs :: [ModSummary]
summs@(ModSummary
summ1:[ModSummary]
_)
  = forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$
    forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$ Module -> [FilePath] -> DriverMessage
DriverDuplicatedModuleDeclaration Module
mod [FilePath]
files
  where
    mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
summ1
    files :: [FilePath]
files = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"checkDup" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModLocation -> Maybe FilePath
ml_hs_file forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location) [ModSummary]
summs

cyclicModuleErr :: [ModuleGraphNode] -> SDoc
-- From a strongly connected component we find
-- a single cycle to report
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss
  = forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleGraphNode]
mss)) forall a b. (a -> b) -> a -> b
$
    case forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node NodeKey ModuleGraphNode]
graph of
       Maybe [ModuleGraphNode]
Nothing   -> FilePath -> SDoc
text FilePath
"Unexpected non-cycle" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mss
       Just [ModuleGraphNode]
path0 -> [SDoc] -> SDoc
vcat
        [ FilePath -> SDoc
text FilePath
"Module graph contains a cycle:"
        , Int -> SDoc -> SDoc
nest Int
2 ([ModuleGraphNode] -> SDoc
show_path [ModuleGraphNode]
path0)]
  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]
nodeDependencies Bool
False ModuleGraphNode
ms
        }
      | ModuleGraphNode
ms <- [ModuleGraphNode]
mss
      ]

    show_path :: [ModuleGraphNode] -> SDoc
    show_path :: [ModuleGraphNode] -> SDoc
show_path []  = forall a. FilePath -> a
panic FilePath
"show_path"
    show_path [ModuleGraphNode
m] = ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"imports itself"
    show_path (ModuleGraphNode
m1:ModuleGraphNode
m2:[ModuleGraphNode]
ms) = [SDoc] -> SDoc
vcat ( Int -> SDoc -> SDoc
nest Int
6 (ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1)
                                forall a. a -> [a] -> [a]
: Int -> SDoc -> SDoc
nest Int
6 (FilePath -> SDoc
text FilePath
"imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m2)
                                forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> [SDoc]
go [ModuleGraphNode]
ms )
       where
         go :: [ModuleGraphNode] -> [SDoc]
go []     = [FilePath -> SDoc
text FilePath
"which imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1]
         go (ModuleGraphNode
m:[ModuleGraphNode]
ms) = (FilePath -> SDoc
text FilePath
"which imports" SDoc -> SDoc -> SDoc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m) forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> [SDoc]
go [ModuleGraphNode]
ms

    ppr_node :: ModuleGraphNode -> SDoc
    ppr_node :: ModuleGraphNode -> SDoc
ppr_node (ModuleNode [NodeKey]
_deps ModSummary
m) = FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms ModSummary
m
    ppr_node (InstantiationNode UnitId
_uid InstantiatedUnit
u) = FilePath -> SDoc
text FilePath
"instantiated unit" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
u
    ppr_node (LinkNode [NodeKey]
uid UnitId
_) = forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"LinkNode should not be in a cycle" (forall a. Outputable a => a -> SDoc
ppr [NodeKey]
uid)

    ppr_ms :: ModSummary -> SDoc
    ppr_ms :: ModSummary -> SDoc
ppr_ms ModSummary
ms = SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
ms))) SDoc -> SDoc -> SDoc
<+>
                (SDoc -> SDoc
parens (FilePath -> SDoc
text (ModSummary -> FilePath
msHsFilePath ModSummary
ms)))


cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe :: forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe Logger
logger TmpFs
tmpfs DynFlags
dflags =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs


addDepsToHscEnv ::  [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv [HomeModInfo]
deps HscEnv
hsc_env =
  (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG (\HomeUnitGraph
hug -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeModInfo -> HomeUnitGraph -> HomeUnitGraph
addHomeModInfoToHug HomeUnitGraph
hug [HomeModInfo]
deps) HscEnv
hsc_env

setHPT ::  HomePackageTable -> HscEnv -> HscEnv
setHPT :: HomePackageTable -> HscEnv -> HscEnv
setHPT HomePackageTable
deps HscEnv
hsc_env =
  (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ HomePackageTable
deps) HscEnv
hsc_env

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

-- | Wrap an action to catch and handle exceptions.
wrapAction :: HscEnv -> IO a -> IO (Maybe a)
wrapAction :: forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction 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
  let logg :: SourceError -> IO ()
logg SourceError
err = forall a. Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
printMessages Logger
lcl_logger (DynFlags -> DiagOpts
initDiagOpts DynFlags
lcl_dynflags) (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 <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ExceptionMonad m => Logger -> m a -> m a
prettyPrintGhcErrors Logger
lcl_logger forall a b. (a -> b) -> a -> b
$ IO a
k
  case Either SomeException a
mres of
    Right a
res -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
res
    Left SomeException
exc -> do
        case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
          Just (SourceError
err :: SourceError)
            -> SourceError -> IO ()
logg SourceError
err
          Maybe SourceError
Nothing -> case 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) -> forall e a. Exception e => e -> IO a
throwIO SomeAsyncException
err
                        Maybe SomeAsyncException
_ -> Logger -> SDoc -> IO ()
errorMsg Logger
lcl_logger (FilePath -> SDoc
text (forall a. Show a => a -> FilePath
show SomeException
exc))
        return forall a. Maybe a
Nothing

withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog :: forall b.
TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog TVar LogQueueQueue
lqq_var Int
k (Logger -> Logger) -> IO b
cont = do
  let init_log :: IO LogQueue
init_log = do
        -- Make a new log queue
        LogQueue
lq <- Int -> IO LogQueue
newLogQueue Int
k
        -- Add it into the LogQueueQueue
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ TVar LogQueueQueue -> LogQueue -> STM ()
initLogQueue TVar LogQueueQueue
lqq_var LogQueue
lq
        return LogQueue
lq
      finish_log :: LogQueue -> m ()
finish_log LogQueue
lq = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LogQueue -> IO ()
finishLogQueue LogQueue
lq)
  forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO LogQueue
init_log forall {m :: * -> *}. MonadIO m => LogQueue -> m ()
finish_log forall a b. (a -> b) -> a -> b
$ \LogQueue
lq -> (Logger -> Logger) -> IO b
cont (((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
 -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> Logger -> Logger
pushLogHook (forall a b. a -> b -> a
const (LogQueue -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
parLogAction LogQueue
lq)))

withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc :: forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv{forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger, HscEnv
hsc_env :: HscEnv
hsc_env :: MakeEnv -> HscEnv
hsc_env} HscEnv -> IO a
cont = do
  forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger Int
k forall a b. (a -> b) -> a -> b
$ \Logger -> Logger
modifyLogger -> do
    let lcl_logger :: Logger
lcl_logger = Logger -> Logger
modifyLogger (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
        hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env { hsc_logger :: Logger
hsc_logger = Logger
lcl_logger }
    -- Run continuation with modified logger
    HscEnv -> IO a
cont HscEnv
hsc_env'


executeInstantiationNode :: Int
  -> Int
  -> RunMakeM HomeUnitGraph
  -> UnitId
  -> InstantiatedUnit
  -> RunMakeM ()
executeInstantiationNode :: Int
-> Int
-> RunMakeM HomeUnitGraph
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode Int
k Int
n RunMakeM HomeUnitGraph
wait_deps UnitId
uid InstantiatedUnit
iu = do
        -- Wait for the dependencies of this node
        HomeUnitGraph
deps <- RunMakeM HomeUnitGraph
wait_deps
        MakeEnv
env <- 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 <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> Maybe Messager
env_messager
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
env forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
          let lcl_hsc_env :: HscEnv
lcl_hsc_env = HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
deps HscEnv
hsc_env
          in forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction HscEnv
lcl_hsc_env 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
            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 :: Int
  -> Int
  -> Maybe HomeModInfo
  -> RunMakeM HomeUnitGraph
  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling
  -> ModSummary
  -> RunMakeM HomeModInfo
executeCompileNode :: Int
-> Int
-> Maybe HomeModInfo
-> RunMakeM HomeUnitGraph
-> Maybe [ModuleName]
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode Int
k Int
n !Maybe HomeModInfo
old_hmi RunMakeM HomeUnitGraph
wait_deps Maybe [ModuleName]
mrehydrate_mods ModSummary
mod = do
  me :: MakeEnv
me@MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: AbstractSem
hsc_env :: HscEnv
env_messager :: MakeEnv -> Maybe Messager
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: MakeEnv -> AbstractSem
hsc_env :: MakeEnv -> HscEnv
..} <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  HomeUnitGraph
deps <- RunMakeM HomeUnitGraph
wait_deps
  -- Rehydrate any dependencies if this module had a boot file or is a signature file.
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem forall a b. (a -> b) -> a -> b
$ forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
me forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
     HscEnv
hydrated_hsc_env <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore (HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
deps HscEnv
hsc_env) ModSummary
mod Maybe [ModuleName]
fixed_mrehydrate_mods
     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
hscSetFlags DynFlags
lcl_dynflags forall a b. (a -> b) -> a -> b
$
             HscEnv
hydrated_hsc_env
     -- Compile the module, locking with a semphore to avoid too many modules
     -- being compiled at the same time leading to high memory usage.
     forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction HscEnv
lcl_hsc_env 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
      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)

  where
    fixed_mrehydrate_mods :: Maybe [ModuleName]
fixed_mrehydrate_mods =
      case ModSummary -> HscSource
ms_hsc_src ModSummary
mod 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.
        HscSource
HsigFile -> forall a. a -> Maybe a
Just []
        HscSource
_ -> Maybe [ModuleName]
mrehydrate_mods

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

rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.
          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.
          -> IO HscEnv
rehydrate :: HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate HscEnv
hsc_env [HomeModInfo]
hmis = do
  Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 forall a b. (a -> b) -> a -> b
$
     FilePath -> SDoc
text FilePath
"Re-hydrating loop: "
  [(ModuleName, HomeModInfo)]
new_mods <- forall a. (a -> IO a) -> IO a
fixIO forall a b. (a -> b) -> a -> b
$ \[(ModuleName, HomeModInfo)]
new_mods -> do
      let new_hpt :: HomePackageTable
new_hpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt HomePackageTable
old_hpt [(ModuleName, HomeModInfo)]
new_mods
      let new_hsc_env :: HscEnv
new_hsc_env = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT (forall a b. a -> b -> a
const HomePackageTable
new_hpt) HscEnv
hsc_env
      [ModDetails]
mds <- forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
text FilePath
"rehydrate") HscEnv
new_hsc_env forall a b. (a -> b) -> a -> b
$
                forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
      let new_mods :: [(ModuleName, HomeModInfo)]
new_mods = [ (ModuleName
mn,HomeModInfo
hmi{ hm_details :: ModDetails
hm_details = ModDetails
details })
                     | (HomeModInfo
hmi,ModDetails
details) <- forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds
                     , let mn :: ModuleName
mn = forall unit. GenModule unit -> ModuleName
moduleName (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)) ]
      forall (m :: * -> *) a. Monad m => a -> m a
return [(ModuleName, HomeModInfo)]
new_mods
  return $ HomePackageTable -> HscEnv -> HscEnv
setHPT (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\HomePackageTable
old (ModuleName
mn, HomeModInfo
hmi) -> HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
old ModuleName
mn HomeModInfo
hmi) HomePackageTable
old_hpt [(ModuleName, HomeModInfo)]
new_mods) HscEnv
hsc_env

  where
    logger :: Logger
logger  = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    to_delete :: [ModuleName]
to_delete =  (forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis)
    -- Filter out old modules before tying the knot, otherwise we can end
    -- up with a thunk which keeps reference to the old HomeModInfo.
    !old_hpt :: HomePackageTable
old_hpt = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) [ModuleName]
to_delete

-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the
-- module currently being compiled.
maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore HscEnv
hsc_env ModSummary
_ Maybe [ModuleName]
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
maybeRehydrateBefore HscEnv
hsc_env ModSummary
mod (Just [ModuleName]
mns) = do
  ModuleEnv (IORef TypeEnv)
knot_var <- HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env
  let hmis :: [HomeModInfo]
hmis = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"mr" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)) [ModuleName]
mns
  HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate (HscEnv
hsc_env { hsc_type_env_vars :: KnotVars (IORef TypeEnv)
hsc_type_env_vars = forall a. ModuleEnv a -> KnotVars a
knotVarsFromModuleEnv ModuleEnv (IORef TypeEnv)
knot_var }) [HomeModInfo]
hmis

  where
   initialise_knot_var :: HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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) (ModSummary -> Module
ms_mod ModSummary
mod)
    in forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module
mod_name,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef TypeEnv
emptyTypeEnv

maybeRehydrateAfter :: HomeModInfo
  -> HscEnv
  -> Maybe [ModuleName]
  -> IO (HomeUnitGraph, HomeModInfo)
maybeRehydrateAfter :: HomeModInfo
-> HscEnv -> Maybe [ModuleName] -> IO (HomeUnitGraph, HomeModInfo)
maybeRehydrateAfter HomeModInfo
hmi HscEnv
new_hsc Maybe [ModuleName]
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
new_hsc, HomeModInfo
hmi)
maybeRehydrateAfter HomeModInfo
hmi HscEnv
new_hsc (Just [ModuleName]
mns) = do
  let new_hpt :: HomePackageTable
new_hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
new_hsc
      hmis :: [HomeModInfo]
hmis = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"mrAfter" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
new_hpt) [ModuleName]
mns
      new_mod_name :: ModuleName
new_mod_name = forall unit. GenModule unit -> ModuleName
moduleName (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi))
  HscEnv
hsc_env <- HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate (HscEnv
new_hsc { hsc_type_env_vars :: KnotVars (IORef TypeEnv)
hsc_type_env_vars = forall a. KnotVars a
emptyKnotVars }) (HomeModInfo
hmi forall a. a -> [a] -> [a]
: [HomeModInfo]
hmis)
  return (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env, forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"rehydrate" forall a b. (a -> b) -> a -> b
$ HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
new_mod_name)

{-
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
type 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.

== 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 the argument type of `MkX`.  So:

* Either we should delay compiling X until after R has beeen 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 :: RunMakeM HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode :: RunMakeM HomeUnitGraph
-> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode RunMakeM HomeUnitGraph
wait_deps (Int, Int)
kn UnitId
uid [NodeKey]
deps = do
  forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
uid forall a b. (a -> b) -> a -> b
$ do
    MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: AbstractSem
hsc_env :: HscEnv
env_messager :: MakeEnv -> Maybe Messager
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: MakeEnv -> AbstractSem
hsc_env :: MakeEnv -> HscEnv
..} <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    HomeUnitGraph
hug <- RunMakeM HomeUnitGraph
wait_deps
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let hsc_env' :: HscEnv
hsc_env' = HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
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)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Messager
env_messager

    SuccessFlag
linkresult <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem forall a b. (a -> b) -> a -> b
$ do
                            GhcLink
-> Logger
-> TmpFs
-> 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 -> 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 -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Link Failed"
      SuccessFlag
Succeeded -> forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Wait for some dependencies to finish and then read from the given MVar.
wait_deps_hug :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
wait_deps_hug :: forall b.
MVar b
-> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
wait_deps_hug MVar b
hug_var [ResultVar (Maybe HomeModInfo)]
deps = do
  [HomeModInfo]
_ <- [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]
wait_deps [ResultVar (Maybe HomeModInfo)]
deps
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar b
hug_var


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


-- Executing the pipelines

-- | Start a thread which reads from the LogQueueQueue


label_self :: String -> IO ()
label_self :: FilePath -> IO ()
label_self FilePath
thread_name = do
    ThreadId
self_tid <- IO ThreadId
CC.myThreadId
    ThreadId -> FilePath -> IO ()
CC.labelThread ThreadId
self_tid FilePath
thread_name


runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
-- Don't even initialise plugins if there are no pipelines
runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines Int
_ HscEnv
_ Maybe Messager
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
runPipelines Int
n_job HscEnv
orig_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self FilePath
"main --make thread"

  HscEnv
plugins_hsc_env <- HscEnv -> IO HscEnv
initializePlugins HscEnv
orig_hsc_env
  case Int
n_job of
    Int
1 -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines HscEnv
plugins_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines
    Int
_n -> Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runParPipelines Int
n_job HscEnv
plugins_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines

runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines HscEnv
plugin_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines =
  let env :: MakeEnv
env = MakeEnv { hsc_env :: HscEnv
hsc_env = HscEnv
plugin_hsc_env
                    , withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger = \Int
_ (Logger -> Logger) -> IO a
k -> (Logger -> Logger) -> IO a
k forall a. a -> a
id
                    , compile_sem :: AbstractSem
compile_sem = IO () -> IO () -> AbstractSem
AbstractSem (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. Monad m => a -> m a
return ())
                    , env_messager :: Maybe Messager
env_messager = Maybe Messager
mHscMessager
                    }
  in Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
1 MakeEnv
env [MakeAction]
all_pipelines


-- | Build and run a pipeline
runParPipelines :: Int              -- ^ How many capabilities to use
             -> HscEnv           -- ^ The basic HscEnv which is augmented with specific info for each module
             -> Maybe Messager   -- ^ Optional custom messager to use to report progress
             -> [MakeAction]  -- ^ The build plan for all the module nodes
             -> IO ()
runParPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runParPipelines Int
n_jobs HscEnv
plugin_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines = do


  -- A variable which we write to when an error has happened and we have to tell the
  -- logging thread to gracefully shut down.
  TVar Bool
stopped_var <- forall a. a -> IO (TVar a)
newTVarIO Bool
False
  -- The queue of LogQueues which actions are able to write to. When an action starts it
  -- will add it's LogQueue into this queue.
  TVar LogQueueQueue
log_queue_queue_var <- forall a. a -> IO (TVar a)
newTVarIO LogQueueQueue
newLogQueueQueue
  -- Thread which coordinates the printing of logs
  IO ()
wait_log_thread <- Int
-> Int -> Logger -> TVar Bool -> TVar LogQueueQueue -> IO (IO ())
logThread Int
n_jobs (forall (t :: * -> *) a. Foldable t => t a -> Int
length [MakeAction]
all_pipelines) (HscEnv -> Logger
hsc_logger HscEnv
plugin_hsc_env) TVar Bool
stopped_var TVar LogQueueQueue
log_queue_queue_var


  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.
  Logger
thread_safe_logger <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> IO Logger
makeThreadSafe (HscEnv -> Logger
hsc_logger HscEnv
plugin_hsc_env)
  let thread_safe_hsc_env :: HscEnv
thread_safe_hsc_env = HscEnv
plugin_hsc_env { hsc_logger :: Logger
hsc_logger = Logger
thread_safe_logger }

  let updNumCapabilities :: IO Int
updNumCapabilities = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          Int
n_capabilities <- IO Int
getNumCapabilities
          Int
n_cpus <- IO Int
getNumProcessors
          -- Setting number of capabilities more than
          -- CPU count usually leads to high userspace
          -- lock contention. #9221
          let n_caps :: Int
n_caps = forall a. Ord a => a -> a -> a
min Int
n_jobs Int
n_cpus
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n_capabilities forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n_caps
          return Int
n_capabilities

  let resetNumCapabilities :: Int -> IO ()
resetNumCapabilities Int
orig_n = do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
orig_n
          forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
stopped_var Bool
True
          IO ()
wait_log_thread

  QSem
compile_sem <- Int -> IO QSem
newQSem Int
n_jobs
  let abstract_sem :: AbstractSem
abstract_sem = IO () -> IO () -> AbstractSem
AbstractSem (QSem -> IO ()
waitQSem QSem
compile_sem) (QSem -> IO ()
signalQSem QSem
compile_sem)
    -- Reset the number of capabilities once the upsweep ends.
  let env :: MakeEnv
env = MakeEnv { hsc_env :: HscEnv
hsc_env = HscEnv
thread_safe_hsc_env
                    , withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger = forall b.
TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog TVar LogQueueQueue
log_queue_queue_var
                    , compile_sem :: AbstractSem
compile_sem = AbstractSem
abstract_sem
                    , env_messager :: Maybe Messager
env_messager = Maybe Messager
mHscMessager
                    }

  forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO Int
updNumCapabilities Int -> IO ()
resetNumCapabilities forall a b. (a -> b) -> a -> b
$ \Int
_ ->
    Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
n_jobs MakeEnv
env [MakeAction]
all_pipelines

withLocalTmpFS :: RunMakeM a -> RunMakeM a
withLocalTmpFS :: forall a. RunMakeM a -> RunMakeM a
withLocalTmpFS RunMakeM a
act = do
  let initialiser :: ReaderT MakeEnv (MaybeT IO) HscEnv
initialiser = do
        MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: AbstractSem
hsc_env :: HscEnv
env_messager :: MakeEnv -> Maybe Messager
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: MakeEnv -> AbstractSem
hsc_env :: MakeEnv -> HscEnv
..} <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        TmpFs
lcl_tmpfs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TmpFs -> IO TmpFs
forkTmpFsFrom (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
        return $ HscEnv
hsc_env { hsc_tmpfs :: TmpFs
hsc_tmpfs  = TmpFs
lcl_tmpfs }
      finaliser :: HscEnv -> ReaderT MakeEnv m ()
finaliser HscEnv
lcl_env = do
        MakeEnv
gbl_env <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TmpFs -> TmpFs -> IO ()
mergeTmpFsInto (HscEnv -> TmpFs
hsc_tmpfs HscEnv
lcl_env) (HscEnv -> TmpFs
hsc_tmpfs (MakeEnv -> HscEnv
hsc_env MakeEnv
gbl_env))
       -- Add remaining files which weren't cleaned up into local tmp fs for
       -- clean-up later.
       -- Clear the logQueue if this node had it's own log queue
  forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket ReaderT MakeEnv (MaybeT IO) HscEnv
initialiser forall {m :: * -> *}. MonadIO m => HscEnv -> ReaderT MakeEnv m ()
finaliser forall a b. (a -> b) -> a -> b
$ \HscEnv
lcl_hsc_env -> forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\MakeEnv
env -> MakeEnv
env { hsc_env :: HscEnv
hsc_env = HscEnv
lcl_hsc_env}) RunMakeM a
act

-- | Run the given actions and then wait for them all to finish.
runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
n_jobs MakeEnv
env [MakeAction]
acts = do
  let spawn_actions :: IO [ThreadId]
      spawn_actions :: IO [ThreadId]
spawn_actions = if Int
n_jobs forall a. Eq a => a -> a -> Bool
== Int
1
        then (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop (\(forall a. IO a -> IO a) -> IO ()
io -> (forall a. IO a -> IO a) -> IO ()
io forall a. IO a -> IO a
unmask) MakeEnv
env [MakeAction]
acts)
        else forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask MakeEnv
env [MakeAction]
acts

      kill_actions :: [ThreadId] -> IO ()
      kill_actions :: [ThreadId] -> IO ()
kill_actions [ThreadId]
tids = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId]
tids

  forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO [ThreadId]
spawn_actions [ThreadId] -> IO ()
kill_actions forall a b. (a -> b) -> a -> b
$ \[ThreadId]
_ -> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MakeAction -> IO ()
waitMakeAction [MakeAction]
acts

-- | Execute each action in order, limiting the amount of parrelism by the given
-- semaphore.
runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]
runLoop :: forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
_ MakeEnv
_env [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread MakeEnv
env (MakeAction RunMakeM a
act MVar (Maybe a)
res_var :[MakeAction]
acts) = do
  a
new_thread <-
    ((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> (do
            Maybe a
mres <- (forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall a. RunMakeM a -> IO (Maybe a)
run_pipeline (forall a. RunMakeM a -> RunMakeM a
withLocalTmpFS RunMakeM a
act))
                      forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`MC.onException` (forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
res_var forall a. Maybe a
Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.
            forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
res_var Maybe a
mres)
  [a]
threads <- forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread MakeEnv
env [MakeAction]
acts
  return (a
new_thread forall a. a -> [a] -> [a]
: [a]
threads)
  where
      run_pipeline :: RunMakeM a -> IO (Maybe a)
      run_pipeline :: forall a. RunMakeM a -> IO (Maybe a)
run_pipeline RunMakeM a
p = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RunMakeM a
p MakeEnv
env)

data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))

waitMakeAction :: MakeAction -> IO ()
waitMakeAction :: MakeAction -> IO ()
waitMakeAction (MakeAction RunMakeM a
_ MVar (Maybe a)
mvar) = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. MVar a -> IO a
readMVar MVar (Maybe a)
mvar

{- 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? dontLeakTheHPT 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.

-}