{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

        downsweep,

        topSortModuleGraph,

        ms_home_srcimps, ms_home_imps,

        summariseModule,
        hscSourceToIsBoot,
        findExtraSigImports,
        implicitRequirements,

        noModError, cyclicModuleErr,
        moduleGraphNodes, SummaryNode,
        IsBootInterface(..)
    ) where

#include "HsVersions.h"

import GHC.Prelude

import qualified GHC.Runtime.Linker as Linker

import GHC.Driver.Phases
import GHC.Driver.Pipeline
import GHC.Driver.Session
import GHC.Utils.Error
import GHC.Driver.Finder
import GHC.Driver.Monad
import GHC.Parser.Header
import GHC.Driver.Types
import GHC.Unit.Module
import GHC.IfaceToCore     ( typecheckIface )
import GHC.Tc.Utils.Monad  ( initIfaceCheck )
import GHC.Driver.Main

import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag )
import GHC.Types.Basic
import GHC.Data.Graph.Directed
import GHC.Utils.Exception ( tryIO )
import GHC.Data.FastString
import GHC.Data.Maybe      ( expectJust )
import GHC.Types.Name
import GHC.Utils.Monad     ( allM )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Data.StringBuffer
import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Tc.Utils.Backpack
import GHC.Unit.State
import GHC.Types.Unique.Set
import GHC.Utils.Misc
import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.Name.Env
import GHC.SysTools.FileCleanup


import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import qualified GHC.Data.FiniteMap as Map ( insertListWith )

import Control.Concurrent ( forkIOWithUnmask, killThread )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.List
import qualified Data.List as List
import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
import System.Directory
import System.FilePath
import System.IO        ( fixIO )
import System.IO.Error  ( isDoesNotExistError )

import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )

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

-- -----------------------------------------------------------------------------
-- 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
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots
    if ErrorMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then ModuleGraph -> m ModuleGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
      else ErrorMessages -> m ModuleGraph
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
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 (ErrorMessages, ModuleGraph)
depanalE :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
    if ErrorMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then do
        let unused_home_mod_err :: [ErrMsg]
unused_home_mod_err = HscEnv -> ModuleGraph -> [ErrMsg]
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph
            unused_pkg_err :: [ErrMsg]
unused_pkg_err = HscEnv -> ModuleGraph -> [ErrMsg]
warnUnusedPackages HscEnv
hsc_env ModuleGraph
mod_graph
            warns :: [ErrMsg]
warns = [ErrMsg]
unused_home_mod_err [ErrMsg] -> [ErrMsg] -> [ErrMsg]
forall a. [a] -> [a] -> [a]
++ [ErrMsg]
unused_pkg_err
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ErrMsg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
warns) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag [ErrMsg]
warns)
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
        (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorMessages
errs, ModuleGraph
mod_graph)
      else do
        -- We don't have a complete module dependency graph,
        -- The graph may be disconnected and is unusable.
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG }
        (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ErrorMessages
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 (ErrorMessages, ModuleGraph)
    -- ^ possibly empty 'Bag' of errors and a module graph.
depanalPartial :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let
         dflags :: DynFlags
dflags  = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
         targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
         old_graph :: ModuleGraph
old_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env

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

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

    [Either ErrorMessages ModSummary]
mod_summariesE <- IO [Either ErrorMessages ModSummary]
-> m [Either ErrorMessages ModSummary]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either ErrorMessages ModSummary]
 -> m [Either ErrorMessages ModSummary])
-> IO [Either ErrorMessages ModSummary]
-> m [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ModSummary]
downsweep HscEnv
hsc_env (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
old_graph)
                                     [ModuleName]
excluded_mods Bool
allow_dup_roots
    let
           ([ErrorMessages]
errs, [ModSummary]
mod_summaries) = [Either ErrorMessages ModSummary]
-> ([ErrorMessages], [ModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ModSummary]
mod_summariesE
           mod_graph :: ModuleGraph
mod_graph = [ModSummary] -> ModuleGraph
mkModuleGraph [ModSummary]
mod_summaries
    (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ErrorMessages] -> ErrorMessages
forall a. [Bag a] -> Bag a
unionManyBags [ErrorMessages]
errs, ModuleGraph
mod_graph)

-- 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 :: HscEnv -> ModuleGraph -> [ErrMsg]
warnMissingHomeModules :: HscEnv -> ModuleGraph -> [ErrMsg]
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph =
    if (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingHomeModules DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing))
    then [ErrMsg
warn]
    else []
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    targets :: [TargetId]
targets = (Target -> TargetId) -> [Target] -> [TargetId]
forall a b. (a -> b) -> [a] -> [b]
map Target -> TargetId
targetId (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env)

    is_known_module :: ModSummary -> Bool
is_known_module ModSummary
mod = (TargetId -> Bool) -> [TargetId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> TargetId -> Bool
is_my_target ModSummary
mod) [TargetId]
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 -> TargetId -> Bool
is_my_target ModSummary
mod (TargetModule ModuleName
name)
      = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
name
    is_my_target ModSummary
mod (TargetFile FilePath
target_file Maybe Phase
_)
      | Just FilePath
mod_file <- ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod)
      = FilePath
target_file FilePath -> FilePath -> Bool
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 FilePath -> FilePath -> Bool
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 ((FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath) -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath, FilePath)
splitExtension FilePath
target_file)
            ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod)
    is_my_target ModSummary
_ TargetId
_ = Bool
False

    missing :: [ModuleName]
missing = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) ([ModSummary] -> [ModuleName]) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
      (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModSummary -> Bool) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
is_known_module) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)

    msg :: SDoc
msg
      | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildingCabalPackage DynFlags
dflags
      = SDoc -> Int -> SDoc -> SDoc
hang
          (FilePath -> SDoc
text FilePath
"These modules are needed for compilation but not listed in your .cabal file's other-modules: ")
          Int
4
          ([SDoc] -> SDoc
sep ((ModuleName -> SDoc) -> [ModuleName] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
      | Bool
otherwise
      =
        SDoc -> Int -> SDoc -> SDoc
hang
          (FilePath -> SDoc
text FilePath
"Modules are not listed in command line but needed for compilation: ")
          Int
4
          ([SDoc] -> SDoc
sep ((ModuleName -> SDoc) -> [ModuleName] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
    warn :: ErrMsg
warn = WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning
      (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingHomeModules)
      (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
noSrcSpan SDoc
msg)

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

-- | 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 target (see 'GHC.Driver.Session.hscTarget') 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 m => LoadHowMuch -> m SuccessFlag
load :: forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
how_much = do
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [] Bool
False                        -- #17459
    SuccessFlag
success <- LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
batchMsg) ModuleGraph
mod_graph
    if ErrorMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then SuccessFlag -> m SuccessFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
      else ErrorMessages -> m SuccessFlag
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
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 :: HscEnv -> ModuleGraph -> [ErrMsg]
warnUnusedPackages :: HscEnv -> ModuleGraph -> [ErrMsg]
warnUnusedPackages HscEnv
hsc_env ModuleGraph
mod_graph =
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        state :: UnitState
state  = DynFlags -> UnitState
unitState DynFlags
dflags

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

        requestedArgs :: [PackageArg]
requestedArgs = (PackageFlag -> Maybe PackageArg) -> [PackageFlag] -> [PackageArg]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageFlag -> Maybe PackageArg
packageArg (DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags)

        unusedArgs :: [PackageArg]
unusedArgs
          = (PackageArg -> Bool) -> [PackageArg] -> [PackageArg]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageArg
arg -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> Bool) -> [UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UnitState -> PackageArg -> UnitInfo -> Bool
matching UnitState
state PackageArg
arg) [UnitInfo]
loadedPackages)
                   [PackageArg]
requestedArgs

        warn :: ErrMsg
warn = WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning
          (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedPackages)
          (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
noSrcSpan SDoc
msg)
        msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ FilePath -> SDoc
text FilePath
"The following packages were specified" SDoc -> SDoc -> SDoc
<+>
                     FilePath -> SDoc
text FilePath
"via -package or -package-id flags,"
                   , FilePath -> SDoc
text FilePath
"but were not needed for compilation:"
                   , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat ((PackageArg -> SDoc) -> [PackageArg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
withDash (SDoc -> SDoc) -> (PackageArg -> SDoc) -> PackageArg -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageArg -> SDoc
pprUnusedArg) [PackageArg]
unusedArgs)) ]

    in if Bool -> Bool
not ([PackageArg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageArg]
unusedArgs) Bool -> Bool -> Bool
&& WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedPackages DynFlags
dflags
       then [ErrMsg
warn]
       else []

    where
        packageArg :: PackageFlag -> Maybe PackageArg
packageArg (ExposePackage FilePath
_ PackageArg
arg ModRenaming
_) = PackageArg -> Maybe PackageArg
forall a. a -> Maybe a
Just PackageArg
arg
        packageArg PackageFlag
_ = Maybe PackageArg
forall a. Maybe a
Nothing

        pprUnusedArg :: PackageArg -> SDoc
pprUnusedArg (PackageArg FilePath
str) = FilePath -> SDoc
text FilePath
str
        pprUnusedArg (UnitIdArg GenUnit UnitId
uid) = GenUnit UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenUnit UnitId
uid

        withDash :: SDoc -> SDoc
withDash = SDoc -> SDoc -> SDoc
(<+>) (FilePath -> SDoc
text FilePath
"-")

        matchingStr :: String -> UnitInfo -> Bool
        matchingStr :: FilePath -> UnitInfo -> Bool
matchingStr FilePath
str UnitInfo
p
                =  FilePath
str FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> FilePath
forall u. GenUnitInfo u -> FilePath
unitPackageIdString UnitInfo
p
                Bool -> Bool -> Bool
|| FilePath
str FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> FilePath
forall u. GenUnitInfo u -> FilePath
unitPackageNameString UnitInfo
p

        matching :: UnitState -> PackageArg -> UnitInfo -> Bool
        matching :: UnitState -> PackageArg -> UnitInfo -> Bool
matching UnitState
_ (PackageArg FilePath
str) UnitInfo
p = FilePath -> UnitInfo -> Bool
matchingStr FilePath
str UnitInfo
p
        matching UnitState
state (UnitIdArg GenUnit UnitId
uid) UnitInfo
p = GenUnit UnitId
uid GenUnit UnitId -> GenUnit UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitState -> UnitInfo -> GenUnit UnitId
realUnit UnitState
state UnitInfo
p

        -- For wired-in packages, we have to unwire their id,
        -- otherwise they won't match package flags
        realUnit :: UnitState -> UnitInfo -> Unit
        realUnit :: UnitState -> UnitInfo -> GenUnit UnitId
realUnit UnitState
state
          = UnitState -> GenUnit UnitId -> GenUnit UnitId
unwireUnit UnitState
state
          (GenUnit UnitId -> GenUnit UnitId)
-> (UnitInfo -> GenUnit UnitId) -> UnitInfo -> GenUnit UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definite UnitId -> GenUnit UnitId
forall uid. Definite uid -> GenUnit uid
RealUnit
          (Definite UnitId -> GenUnit UnitId)
-> (UnitInfo -> Definite UnitId) -> UnitInfo -> GenUnit UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite
          (UnitId -> Definite UnitId)
-> (UnitInfo -> UnitId) -> UnitInfo -> Definite UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId

-- | Generalized version of 'load' which also supports a custom
-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
-- produced by calling 'depanal'.
load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
    (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
    m ()
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    let hpt1 :: HomePackageTable
hpt1   = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags 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 :: UniqSet ModuleName
all_home_mods =
          [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [ ModSummary -> ModuleName
ms_mod_name ModSummary
s
                    | ModSummary
s <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
s IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot]
    -- TODO: Figure out what the correct form of this assert is. It's violated
    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
    -- files without corresponding hs files.
    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
    --                              not (ms_mod_name s `elem` all_home_mods)]
    -- ASSERT( null bad_boot_mods ) return ()

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

        checkMod :: ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m m SuccessFlag
and_then
            | ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods = m SuccessFlag
and_then
            | Bool
otherwise = do
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
errorMsg DynFlags
dflags (FilePath -> SDoc
text FilePath
"no such module:" SDoc -> SDoc -> SDoc
<+>
                                     SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m))
                    SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed

    LoadHowMuch -> m SuccessFlag -> m SuccessFlag
forall {m :: * -> *}.
MonadIO m =>
LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch LoadHowMuch
how_much (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ do

    -- mg2_with_srcimps drops the hi-boot nodes, returning a
    -- graph with cycles.  Among other things, it is used for
    -- backing out partially complete cycles following a failed
    -- upsweep, and for removing from hpt all the modules
    -- not in strict downwards closure, during calls to compile.
    let mg2_with_srcimps :: [SCC ModSummary]
        mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
True ModuleGraph
mod_graph Maybe ModuleName
forall a. Maybe a
Nothing

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

    let
        -- check the stability property for each module.
        stable_mods :: (UniqSet ModuleName, UniqSet ModuleName)
stable_mods@(UniqSet ModuleName
stable_obj,UniqSet ModuleName
stable_bco)
            = HomePackageTable
-> [SCC ModSummary]
-> UniqSet ModuleName
-> (UniqSet ModuleName, UniqSet ModuleName)
checkStability HomePackageTable
hpt1 [SCC ModSummary]
mg2_with_srcimps UniqSet ModuleName
all_home_mods

        -- prune bits of the HPT which are definitely redundant now,
        -- to save space.
        pruned_hpt :: HomePackageTable
pruned_hpt = HomePackageTable
-> [ModSummary]
-> (UniqSet ModuleName, UniqSet ModuleName)
-> HomePackageTable
pruneHomePackageTable HomePackageTable
hpt1
                            ([SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs [SCC ModSummary]
mg2_with_srcimps)
                            (UniqSet ModuleName, UniqSet ModuleName)
stable_mods

    HomePackageTable
_ <- IO HomePackageTable -> m HomePackageTable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomePackageTable -> m HomePackageTable)
-> IO HomePackageTable -> m HomePackageTable
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> IO HomePackageTable
forall a. a -> IO a
evaluate HomePackageTable
pruned_hpt

    -- before we unload anything, make sure we don't leave an old
    -- interactive context around pointing to dead bindings.  Also,
    -- write the pruned HPT to allow the old HPT to be GC'd.
    HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
pruned_hpt }

    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Stable obj:" SDoc -> SDoc -> SDoc
<+> UniqSet ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_obj SDoc -> SDoc -> SDoc
$$
                            FilePath -> SDoc
text FilePath
"Stable BCO:" SDoc -> SDoc -> SDoc
<+> UniqSet ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_bco)

    -- Unload any modules which are going to be re-linked this time around.
    let stable_linkables :: [Linkable]
stable_linkables = [ Linkable
linkable
                           | ModuleName
m <- UniqSet ModuleName -> [ModuleName]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_obj [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++
                                  UniqSet ModuleName -> [ModuleName]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_bco,
                             -- It's OK to use nonDetEltsUniqSet here
                             -- because it only affects linking. Besides
                             -- this list only serves as a poor man's set.
                             Just HomeModInfo
hmi <- [HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
pruned_hpt ModuleName
m],
                             Just Linkable
linkable <- [HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi] ]
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [Linkable] -> IO ()
unload HscEnv
hsc_env [Linkable]
stable_linkables

    -- We could at this point detect cycles which aren't broken by
    -- a source-import, and complain immediately, but it seems better
    -- to let upsweep_mods do this, so at least some useful work gets
    -- done before the upsweep is abandoned.
    --hPutStrLn stderr "after tsort:\n"
    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))

    -- Now do the upsweep, calling compile for each module in
    -- turn.  Final result is version 3 of everything.

    -- Topologically sort the module graph, this time including hi-boot
    -- nodes, and possibly just including the portion of the graph
    -- reachable from the module specified in the 2nd argument to load.
    -- This graph should be cycle-free.
    -- If we're restricting the upsweep to a portion of the graph, we
    -- also want to retain everything that is still stable.
    let full_mg :: [SCC ModSummary]
        full_mg :: [SCC ModSummary]
full_mg    = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe ModuleName
forall a. Maybe a
Nothing

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

        partial_mg0 :: [SCC ModSummary]
        partial_mg0 :: [SCC ModSummary]
partial_mg0 = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe ModuleName
maybe_top_mod

        -- LoadDependenciesOf m: we want the upsweep to stop just
        -- short of the specified module (unless the specified module
        -- is stable).
        partial_mg :: [SCC ModSummary]
partial_mg
            | LoadDependenciesOf ModuleName
_mod <- LoadHowMuch
how_much
            = ASSERT( case last partial_mg0 of
                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
              [SCC ModSummary] -> [SCC ModSummary]
forall a. [a] -> [a]
List.init [SCC ModSummary]
partial_mg0
            | Bool
otherwise
            = [SCC ModSummary]
partial_mg0

        stable_mg :: [SCC ModSummary]
stable_mg =
            [ ModSummary -> SCC ModSummary
forall vertex. vertex -> SCC vertex
AcyclicSCC ModSummary
ms
            | AcyclicSCC ModSummary
ms <- [SCC ModSummary]
full_mg,
              ModSummary -> Bool
stable_mod_summary ModSummary
ms ]

        stable_mod_summary :: ModSummary -> Bool
stable_mod_summary ModSummary
ms =
          ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj Bool -> Bool -> Bool
||
          ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco

        -- the modules from partial_mg that are not also stable
        -- NB. also keep cycles, we need to emit an error message later
        unstable_mg :: [SCC ModSummary]
unstable_mg = (SCC ModSummary -> Bool) -> [SCC ModSummary] -> [SCC ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter SCC ModSummary -> Bool
not_stable [SCC ModSummary]
partial_mg
          where not_stable :: SCC ModSummary -> Bool
not_stable (CyclicSCC [ModSummary]
_) = Bool
True
                not_stable (AcyclicSCC ModSummary
ms)
                   = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ModSummary -> Bool
stable_mod_summary ModSummary
ms

        -- Load all the stable modules first, before attempting to load
        -- an unstable module (#7231).
        mg :: [SCC ModSummary]
mg = [SCC ModSummary]
stable_mg [SCC ModSummary] -> [SCC ModSummary] -> [SCC ModSummary]
forall a. [a] -> [a] -> [a]
++ [SCC ModSummary]
unstable_mg

    -- clean up between compilations
    let cleanup :: HscEnv -> IO ()
cleanup = DynFlags -> IO ()
cleanCurrentModuleTempFiles (DynFlags -> IO ()) -> (HscEnv -> DynFlags) -> HscEnv -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> DynFlags
hsc_dflags
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text FilePath
"Ready for upsweep")
                               Int
2 ([SCC ModSummary] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SCC ModSummary]
mg))

    Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount DynFlags
dflags of
                    Maybe Int
Nothing -> IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
                    Just Int
n  -> Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
    let upsweep_fn :: Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
upsweep_fn | Int
n_jobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = Int
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
forall (m :: * -> *).
GhcMonad m =>
Int
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
parUpsweep Int
n_jobs
                   | Bool
otherwise  = Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
upsweep

    HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }
    (SuccessFlag
upsweep_ok, [ModSummary]
modsUpswept) <- m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics (m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall a b. (a -> b) -> a -> b
$
      Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
upsweep_fn Maybe Messager
mHscMessage HomePackageTable
pruned_hpt (UniqSet ModuleName, UniqSet ModuleName)
stable_mods HscEnv -> IO ()
cleanup [SCC ModSummary]
mg

    -- Make modsDone be the summaries for each home module now
    -- available; this should equal the domain of hpt3.
    -- Get in in a roughly top .. bottom order (hence reverse).

    let modsDone :: [ModSummary]
modsDone = [ModSummary] -> [ModSummary]
forall a. [a] -> [a]
reverse [ModSummary]
modsUpswept

    -- Try and do linking in some form, depending on whether the
    -- upsweep was completely or only partially successful.

    if SuccessFlag -> Bool
succeeded SuccessFlag
upsweep_ok

     then
       -- Easy; just relink it all.
       do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Upsweep completely successful.")

          -- Clean up after ourselves
          HscEnv
hsc_env1 <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
cleanCurrentModuleTempFiles DynFlags
dflags

          -- 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.
          --
          let ofile :: Maybe FilePath
ofile = DynFlags -> Maybe FilePath
outputFile DynFlags
dflags
          let no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
          let
            main_mod :: Module
main_mod = DynFlags -> Module
mainModIs DynFlags
dflags
            a_root_is_Main :: Bool
a_root_is_Main = ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph
mod_graph Module
main_mod
            do_linking :: Bool
do_linking = Bool
a_root_is_Main Bool -> Bool -> Bool
|| Bool
no_hs_main Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib

          -- link everything together
          SuccessFlag
linkresult <- IO SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SuccessFlag -> m SuccessFlag)
-> IO SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link (DynFlags -> GhcLink
ghcLink DynFlags
dflags) DynFlags
dflags Bool
do_linking (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1)

          if DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkBinary Bool -> Bool -> Bool
&& Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
ofile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
do_linking
             then do
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
errorMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text
                   (FilePath
"output was redirected with -o, " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    FilePath
"but no output will be generated\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    FilePath
"because there is no " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    ModuleName -> FilePath
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
main_mod) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" module.")
                -- This should be an error, not a warning (#10895).
                SuccessFlag -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
Failed SuccessFlag
linkresult
             else
                SuccessFlag -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
Succeeded SuccessFlag
linkresult

     else
       -- Tricky.  We need to back out the effects of compiling any
       -- half-done cycles, both so as to clean up the top level envs
       -- and to avoid telling the interactive linker to link them.
       do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Upsweep partially successful.")

          let modsDone_names :: [Module]
modsDone_names
                 = (ModSummary -> Module) -> [ModSummary] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> Module
ms_mod [ModSummary]
modsDone
          let mods_to_zap_names :: Set Module
mods_to_zap_names
                 = [Module] -> [SCC ModSummary] -> Set Module
findPartiallyCompletedCycles [Module]
modsDone_names
                      [SCC ModSummary]
mg2_with_srcimps
          let ([ModSummary]
mods_to_clean, [ModSummary]
mods_to_keep) =
                (ModSummary -> Bool)
-> [ModSummary] -> ([ModSummary], [ModSummary])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Module -> Set Module -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
mods_to_zap_names)(Module -> Bool) -> (ModSummary -> Module) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModSummary -> Module
ms_mod) [ModSummary]
modsDone
          HscEnv
hsc_env1 <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          let hpt4 :: HomePackageTable
hpt4 = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1
              -- We must change the lifetime to TFL_CurrentModule for any temp
              -- file created for an element of mod_to_clean during the upsweep.
              -- These include preprocessed files and object files for loaded
              -- modules.
              unneeded_temps :: [FilePath]
unneeded_temps = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [FilePath
ms_hspp_file FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
object_files
                | ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod, FilePath
ms_hspp_file :: ModSummary -> FilePath
ms_hspp_file :: FilePath
ms_hspp_file} <- [ModSummary]
mods_to_clean
                , let object_files :: [FilePath]
object_files = [FilePath]
-> (Linkable -> [FilePath]) -> Maybe Linkable -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Linkable -> [FilePath]
linkableObjs (Maybe Linkable -> [FilePath]) -> Maybe Linkable -> [FilePath]
forall a b. (a -> b) -> a -> b
$
                        HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt4 (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
ms_mod)
                        Maybe HomeModInfo
-> (HomeModInfo -> Maybe Linkable) -> Maybe Linkable
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HomeModInfo -> Maybe Linkable
hm_linkable
                ]
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
            DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime DynFlags
dflags TempFileLifetime
TFL_CurrentModule [FilePath]
unneeded_temps
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
cleanCurrentModuleTempFiles DynFlags
dflags

          let hpt5 :: HomePackageTable
hpt5 = [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
mods_to_keep)
                                          HomePackageTable
hpt4

          -- Clean up after ourselves

          -- there should be no Nothings where linkables should be, now
          let just_linkables :: Bool
just_linkables =
                    GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
                 Bool -> Bool -> Bool
|| (HomeModInfo -> Bool) -> HomePackageTable -> Bool
allHpt (Maybe Linkable -> Bool
forall a. Maybe a -> Bool
isJust(Maybe Linkable -> Bool)
-> (HomeModInfo -> Maybe Linkable) -> HomeModInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> Maybe Linkable
hm_linkable)
                        ((HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
filterHpt ((HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile)(HscSource -> Bool)
-> (HomeModInfo -> HscSource) -> HomeModInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModIface_ 'ModIfaceFinal -> HscSource
forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_src(ModIface_ 'ModIfaceFinal -> HscSource)
-> (HomeModInfo -> ModIface_ 'ModIfaceFinal)
-> HomeModInfo
-> HscSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface)
                                HomePackageTable
hpt5)
          ASSERT( just_linkables ) do

          -- Link everything together
          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5

          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
          loadFinish Failed linkresult


-- | Finish up after a load.
loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag

-- If the link failed, unload everything and return.
loadFinish :: forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
_all_ok SuccessFlag
Failed
  = do HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
       IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [Linkable] -> IO ()
unload HscEnv
hsc_env []
       (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardProg
       SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed

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


-- | Forget the current program, but retain the persistent info in HscEnv
discardProg :: HscEnv -> HscEnv
discardProg :: HscEnv -> HscEnv
discardProg HscEnv
hsc_env
  = HscEnv -> HscEnv
discardIC (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG
                        , hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }

-- | Discard the contents of the InteractiveContext, but keep the DynFlags.
-- It will also keep ic_int_print and ic_monad if their names are from
-- external packages.
discardIC :: HscEnv -> HscEnv
discardIC :: HscEnv -> HscEnv
discardIC HscEnv
hsc_env
  = HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
empty_ic { ic_int_print :: Name
ic_int_print = Name
new_ic_int_print
                                , ic_monad :: Name
ic_monad = Name
new_ic_monad } }
  where
  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
  !new_ic_int_print :: Name
new_ic_int_print = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_int_print
  !new_ic_monad :: Name
new_ic_monad = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_monad
  dflags :: DynFlags
dflags = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
old_ic
  old_ic :: InteractiveContext
old_ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
  empty_ic :: InteractiveContext
empty_ic = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
  keep_external_name :: (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_name
    | GenUnit UnitId -> Name -> Bool
nameIsFromExternalPackage GenUnit UnitId
this_pkg Name
old_name = Name
old_name
    | Bool
otherwise = InteractiveContext -> Name
ic_name InteractiveContext
empty_ic
    where
    this_pkg :: GenUnit UnitId
this_pkg = DynFlags -> GenUnit UnitId
homeUnit DynFlags
dflags
    old_name :: Name
old_name = InteractiveContext -> Name
ic_name InteractiveContext
old_ic

-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
guessOutputFile :: GhcMonad m => m ()
guessOutputFile :: forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
env ->
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
        -- Force mod_graph to avoid leaking env
        !mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
        mainModuleSrcPath :: Maybe String
        mainModuleSrcPath :: Maybe FilePath
mainModuleSrcPath = do
            ModSummary
ms <- ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph
mod_graph (DynFlags -> Module
mainModIs DynFlags
dflags)
            ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
        name :: Maybe FilePath
name = (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
dropExtension Maybe FilePath
mainModuleSrcPath

        name_exe :: Maybe FilePath
name_exe = do
#if defined(mingw32_HOST_OS)
          -- 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
          name' <- fmap (<.> "exe") name
#else
          FilePath
name' <- Maybe FilePath
name
#endif
          FilePath
mainModuleSrcPath' <- Maybe FilePath
mainModuleSrcPath
          -- #9930: don't clobber input files (unless they ask for it)
          if FilePath
name' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
mainModuleSrcPath'
            then GhcException -> Maybe FilePath
forall a. GhcException -> a
throwGhcException (GhcException -> Maybe FilePath)
-> (FilePath -> GhcException) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
UsageError (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$
                 FilePath
"default output name would overwrite the input file; " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                 FilePath
"must specify -o explicitly"
            else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
name'
    in
    case DynFlags -> Maybe FilePath
outputFile DynFlags
dflags of
        Just FilePath
_ -> HscEnv
env
        Maybe FilePath
Nothing -> HscEnv
env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags { outputFile :: Maybe FilePath
outputFile = Maybe FilePath
name_exe } }

-- -----------------------------------------------------------------------------
--
-- | Prune the HomePackageTable
--
-- Before doing an upsweep, we can throw away:
--
--   - For non-stable modules:
--      - 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.
pruneHomePackageTable :: HomePackageTable
                      -> [ModSummary]
                      -> StableModules
                      -> HomePackageTable
pruneHomePackageTable :: HomePackageTable
-> [ModSummary]
-> (UniqSet ModuleName, UniqSet ModuleName)
-> HomePackageTable
pruneHomePackageTable HomePackageTable
hpt [ModSummary]
summ (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco)
  = (HomeModInfo -> HomeModInfo)
-> HomePackageTable -> HomePackageTable
mapHpt HomeModInfo -> HomeModInfo
prune HomePackageTable
hpt
  where prune :: HomeModInfo -> HomeModInfo
prune HomeModInfo
hmi
          | ModuleName -> Bool
is_stable ModuleName
modl = HomeModInfo
hmi'
          | Bool
otherwise      = HomeModInfo
hmi'{ hm_details :: ModDetails
hm_details = ModDetails
emptyModDetails }
          where
           modl :: ModuleName
modl = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hmi))
           hmi' :: HomeModInfo
hmi' | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi, Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< ModSummary -> UTCTime
ms_hs_date ModSummary
ms
                = HomeModInfo
hmi{ hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
forall a. Maybe a
Nothing }
                | Bool
otherwise
                = HomeModInfo
hmi
                where ms :: ModSummary
ms = FilePath -> Maybe ModSummary -> ModSummary
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"prune" (UniqFM ModuleName ModSummary -> ModuleName -> Maybe ModSummary
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM ModuleName ModSummary
ms_map ModuleName
modl)

        ms_map :: UniqFM ModuleName ModSummary
ms_map = [(ModuleName, ModSummary)] -> UniqFM ModuleName ModSummary
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(ModSummary -> ModuleName
ms_mod_name ModSummary
ms, ModSummary
ms) | ModSummary
ms <- [ModSummary]
summ]

        is_stable :: ModuleName -> Bool
is_stable ModuleName
m =
          ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj Bool -> Bool -> Bool
||
          ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco

-- -----------------------------------------------------------------------------
--
-- | Return (names of) all those in modsDone who are part of a cycle as defined
-- by theGraph.
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set Module
findPartiallyCompletedCycles [Module]
modsDone [SCC ModSummary]
theGraph
   = [Set Module] -> Set Module
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
       [Set Module
mods_in_this_cycle
       | CyclicSCC [ModSummary]
vs <- [SCC ModSummary]
theGraph  -- Acyclic? Not interesting.
       , let names_in_this_cycle :: Set Module
names_in_this_cycle = [Module] -> Set Module
forall a. Ord a => [a] -> Set a
Set.fromList ((ModSummary -> Module) -> [ModSummary] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> Module
ms_mod [ModSummary]
vs)
             mods_in_this_cycle :: Set Module
mods_in_this_cycle =
                    Set Module -> Set Module -> Set Module
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection ([Module] -> Set Module
forall a. Ord a => [a] -> Set a
Set.fromList [Module]
modsDone) Set Module
names_in_this_cycle
         -- If size mods_in_this_cycle == size names_in_this_cycle,
         -- then this cycle has already been completed and we're not
         -- interested.
       , Set Module -> Int
forall a. Set a -> Int
Set.size Set Module
mods_in_this_cycle Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Set Module -> Int
forall a. Set a -> Int
Set.size Set Module
names_in_this_cycle]


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

-- -----------------------------------------------------------------------------
{- |

  Stability tells us which modules definitely do not need to be recompiled.
  There are two main reasons for having stability:

   - avoid doing a complete upsweep of the module graph in GHCi when
     modules near the bottom of the tree have not changed.

   - to tell GHCi when it can load object code: we can only load object code
     for a module when we also load object code fo  all of the imports of the
     module.  So we need to know that we will definitely not be recompiling
     any of these modules, and we can use the object code.

  The stability check is as follows.  Both stableObject and
  stableBCO are used during the upsweep phase later.

@
  stable m = stableObject m || stableBCO m

  stableObject m =
        all stableObject (imports m)
        && old linkable does not exist, or is == on-disk .o
        && date(on-disk .o) > date(.hs)

  stableBCO m =
        all stable (imports m)
        && date(BCO) > date(.hs)
@

  These properties embody the following ideas:

    - if a module is stable, then:

        - if it has been compiled in a previous pass (present in HPT)
          then it does not need to be compiled or re-linked.

        - if it has not been compiled in a previous pass,
          then we only need to read its .hi file from disk and
          link it to produce a 'ModDetails'.

    - if a modules is not stable, we will definitely be at least
      re-linking, and possibly re-compiling it during the 'upsweep'.
      All non-stable modules can (and should) therefore be unlinked
      before the 'upsweep'.

    - Note that objects are only considered stable if they only depend
      on other objects.  We can't link object code against byte code.

    - Note that even if an object is stable, we may end up recompiling
      if the interface is out of date because an *external* interface
      has changed.  The current code in GHC.Driver.Make handles this case
      fairly poorly, so be careful.
-}

type StableModules =
  ( UniqSet ModuleName  -- stableObject
  , UniqSet ModuleName  -- stableBCO
  )


checkStability
        :: HomePackageTable   -- HPT from last compilation
        -> [SCC ModSummary]   -- current module graph (cyclic)
        -> UniqSet ModuleName -- all home modules
        -> StableModules

checkStability :: HomePackageTable
-> [SCC ModSummary]
-> UniqSet ModuleName
-> (UniqSet ModuleName, UniqSet ModuleName)
checkStability HomePackageTable
hpt [SCC ModSummary]
sccs UniqSet ModuleName
all_home_mods =
  ((UniqSet ModuleName, UniqSet ModuleName)
 -> SCC ModSummary -> (UniqSet ModuleName, UniqSet ModuleName))
-> (UniqSet ModuleName, UniqSet ModuleName)
-> [SCC ModSummary]
-> (UniqSet ModuleName, UniqSet ModuleName)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (UniqSet ModuleName, UniqSet ModuleName)
-> SCC ModSummary -> (UniqSet ModuleName, UniqSet ModuleName)
checkSCC (UniqSet ModuleName
forall a. UniqSet a
emptyUniqSet, UniqSet ModuleName
forall a. UniqSet a
emptyUniqSet) [SCC ModSummary]
sccs
  where
   checkSCC :: StableModules -> SCC ModSummary -> StableModules
   checkSCC :: (UniqSet ModuleName, UniqSet ModuleName)
-> SCC ModSummary -> (UniqSet ModuleName, UniqSet ModuleName)
checkSCC (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco) SCC ModSummary
scc0
     | Bool
stableObjects = (UniqSet ModuleName -> [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet ModuleName
stable_obj [ModuleName]
scc_mods, UniqSet ModuleName
stable_bco)
     | Bool
stableBCOs    = (UniqSet ModuleName
stable_obj, UniqSet ModuleName -> [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet ModuleName
stable_bco [ModuleName]
scc_mods)
     | Bool
otherwise     = (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco)
     where
        scc :: [ModSummary]
scc = SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC SCC ModSummary
scc0
        scc_mods :: [ModuleName]
scc_mods = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
scc
        home_module :: ModuleName -> Bool
home_module ModuleName
m =
          ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods Bool -> Bool -> Bool
&& ModuleName
m ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
scc_mods

        scc_allimps :: [ModuleName]
scc_allimps = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ((ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
home_module ((ModSummary -> [ModuleName]) -> [ModSummary] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [ModuleName]
ms_home_allimps [ModSummary]
scc))
            -- all imports outside the current SCC, but in the home pkg

        stable_obj_imps :: [Bool]
stable_obj_imps = (ModuleName -> Bool) -> [ModuleName] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj) [ModuleName]
scc_allimps
        stable_bco_imps :: [Bool]
stable_bco_imps = (ModuleName -> Bool) -> [ModuleName] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco) [ModuleName]
scc_allimps

        stableObjects :: Bool
stableObjects =
           [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
stable_obj_imps
           Bool -> Bool -> Bool
&& (ModSummary -> Bool) -> [ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModSummary -> Bool
object_ok [ModSummary]
scc

        stableBCOs :: Bool
stableBCOs =
           [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(||) [Bool]
stable_obj_imps [Bool]
stable_bco_imps)
           Bool -> Bool -> Bool
&& (ModSummary -> Bool) -> [ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModSummary -> Bool
bco_ok [ModSummary]
scc

        object_ok :: ModSummary -> Bool
object_ok ModSummary
ms
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) = Bool
False
          | Just UTCTime
t <- ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
ms  =  UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
ms
                                         Bool -> Bool -> Bool
&& UTCTime -> Bool
same_as_prev UTCTime
t
          | Bool
otherwise = Bool
False
          where
             same_as_prev :: UTCTime -> Bool
same_as_prev UTCTime
t = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) of
                                Just HomeModInfo
hmi  | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi
                                 -> Linkable -> Bool
isObjectLinkable Linkable
l Bool -> Bool -> Bool
&& UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== Linkable -> UTCTime
linkableTime Linkable
l
                                Maybe HomeModInfo
_other  -> Bool
True
                -- why '>=' rather than '>' above?  If the filesystem stores
                -- times to the nearest second, we may occasionally find that
                -- the object & source have the same modification time,
                -- especially if the source was automatically generated
                -- and compiled.  Using >= is slightly unsafe, but it matches
                -- make's behaviour.
                --
                -- But see #5527, where someone ran into this and it caused
                -- a problem.

        bco_ok :: ModSummary -> Bool
bco_ok ModSummary
ms
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) = Bool
False
          | Bool
otherwise = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) of
                Just HomeModInfo
hmi  | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi ->
                        Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
l) Bool -> Bool -> Bool
&&
                        Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
ms
                Maybe HomeModInfo
_other  -> Bool
False

{- Parallel Upsweep
 -
 - The parallel upsweep attempts to concurrently compile the modules in the
 - compilation graph using multiple Haskell threads.
 -
 - The Algorithm
 -
 - A Haskell thread is spawned for each module in the module graph, waiting for
 - its direct dependencies to finish building before it itself begins to build.
 -
 - Each module is associated with an initially empty MVar that stores the
 - result of that particular module's compile. If the compile succeeded, then
 - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that
 - module, and the module's HMI is deleted from the old HPT (synchronized by an
 - IORef) to save space.
 -
 - Instead of immediately outputting messages to the standard handles, all
 - compilation output is deferred to a per-module TQueue. A QSem is used to
 - limit the number of workers that are compiling simultaneously.
 -
 - Meanwhile, the main thread sequentially loops over all the modules in the
 - module graph, outputting the messages stored in each module's TQueue.
-}

-- | Each module is given a unique 'LogQueue' to redirect compilation messages
-- to. A 'Nothing' value contains the result of compilation, and denotes the
-- end of the message queue.
data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, MsgDoc)])
                         !(MVar ())

-- | The graph of modules to compile and their corresponding result 'MVar' and
-- 'LogQueue'.
type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]

-- | Build a 'CompilationGraph' out of a list of strongly-connected modules,
-- also returning the first, if any, encountered module cycle.
buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph [] = (CompilationGraph, Maybe [ModSummary])
-> IO (CompilationGraph, Maybe [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe [ModSummary]
forall a. Maybe a
Nothing)
buildCompGraph (SCC ModSummary
scc:[SCC ModSummary]
sccs) = case SCC ModSummary
scc of
    AcyclicSCC ModSummary
ms -> do
        MVar SuccessFlag
mvar <- IO (MVar SuccessFlag)
forall a. IO (MVar a)
newEmptyMVar
        LogQueue
log_queue <- do
            IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref <- [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> IO (IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)])
forall a. a -> IO (IORef a)
newIORef []
            MVar ()
sem <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
            LogQueue -> IO LogQueue
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> MVar () -> LogQueue
LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem)
        (CompilationGraph
rest,Maybe [ModSummary]
cycle) <- [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph [SCC ModSummary]
sccs
        (CompilationGraph, Maybe [ModSummary])
-> IO (CompilationGraph, Maybe [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModSummary
ms,MVar SuccessFlag
mvar,LogQueue
log_queue)(ModSummary, MVar SuccessFlag, LogQueue)
-> CompilationGraph -> CompilationGraph
forall a. a -> [a] -> [a]
:CompilationGraph
rest, Maybe [ModSummary]
cycle)
    CyclicSCC [ModSummary]
mss -> (CompilationGraph, Maybe [ModSummary])
-> IO (CompilationGraph, Maybe [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [ModSummary] -> Maybe [ModSummary]
forall a. a -> Maybe a
Just [ModSummary]
mss)

-- | A Module and whether it is a boot module.
--
-- We need to treat boot modules specially when building compilation graphs,
-- since they break cycles. Regular source files and signature files are treated
-- equivalently.
type BuildModule = ModuleWithIsBoot

-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements
-- of 'BuildModule'. We conflate signatures and modules because they are bound
-- in the same namespace; only boot interfaces can be disambiguated with
-- `import {-# SOURCE #-}`.
hscSourceToIsBoot :: HscSource -> IsBootInterface
hscSourceToIsBoot :: HscSource -> IsBootInterface
hscSourceToIsBoot HscSource
HsBootFile = IsBootInterface
IsBoot
hscSourceToIsBoot HscSource
_ = IsBootInterface
NotBoot

mkBuildModule :: ModSummary -> BuildModule
mkBuildModule :: ModSummary -> BuildModule
mkBuildModule ModSummary
ms = GWIB :: forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB
  { gwib_mod :: Module
gwib_mod = ModSummary -> Module
ms_mod ModSummary
ms
  , gwib_isBoot :: IsBootInterface
gwib_isBoot = ModSummary -> IsBootInterface
isBootSummary ModSummary
ms
  }

mkHomeBuildModule :: ModSummary -> ModuleNameWithIsBoot
mkHomeBuildModule :: ModSummary -> NodeKey
mkHomeBuildModule ModSummary
ms = GWIB :: forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB
  { gwib_mod :: ModuleName
gwib_mod = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
ms
  , gwib_isBoot :: IsBootInterface
gwib_isBoot = ModSummary -> IsBootInterface
isBootSummary ModSummary
ms
  }

-- | The entry point to the parallel upsweep.
--
-- See also the simpler, sequential 'upsweep'.
parUpsweep
    :: GhcMonad m
    => Int
    -- ^ The number of workers we wish to run in parallel
    -> Maybe Messager
    -> HomePackageTable
    -> StableModules
    -> (HscEnv -> IO ())
    -> [SCC ModSummary]
    -> m (SuccessFlag,
          [ModSummary])
parUpsweep :: forall (m :: * -> *).
GhcMonad m =>
Int
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
parUpsweep Int
n_jobs Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName, UniqSet ModuleName)
stable_mods HscEnv -> IO ()
cleanup [SCC ModSummary]
sccs = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([GenUnit UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> [GenUnit UnitId]
instantiatedUnitsToCheck DynFlags
dflags))) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      GhcException -> m ()
forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
ProgramError FilePath
"Backpack typechecking not supported with -j")

    -- The bits of shared state we'll be using:

    -- The global HscEnv is updated with the module's HMI when a module
    -- successfully compiles.
    MVar HscEnv
hsc_env_var <- IO (MVar HscEnv) -> m (MVar HscEnv)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar HscEnv) -> m (MVar HscEnv))
-> IO (MVar HscEnv) -> m (MVar HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO (MVar HscEnv)
forall a. a -> IO (MVar a)
newMVar HscEnv
hsc_env

    -- The old HPT is used for recompilation checking in upsweep_mod. When a
    -- module successfully gets compiled, its HMI is pruned from the old HPT.
    IORef HomePackageTable
old_hpt_var <- IO (IORef HomePackageTable) -> m (IORef HomePackageTable)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef HomePackageTable) -> m (IORef HomePackageTable))
-> IO (IORef HomePackageTable) -> m (IORef HomePackageTable)
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> IO (IORef HomePackageTable)
forall a. a -> IO (IORef a)
newIORef HomePackageTable
old_hpt

    -- What we use to limit parallelism with.
    QSem
par_sem <- IO QSem -> m QSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO QSem -> m QSem) -> IO QSem -> m QSem
forall a b. (a -> b) -> a -> b
$ Int -> IO QSem
newQSem Int
n_jobs


    let updNumCapabilities :: m Int
updNumCapabilities = IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
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 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n_jobs Int
n_cpus
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n_capabilities Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n_caps
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n_capabilities
    -- Reset the number of capabilities once the upsweep ends.
    let resetNumCapabilities :: Int -> m ()
resetNumCapabilities Int
orig_n = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
orig_n

    m Int
-> (Int -> m ())
-> (Int -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket m Int
updNumCapabilities Int -> m ()
forall {m :: * -> *}. MonadIO m => Int -> m ()
resetNumCapabilities ((Int -> m (SuccessFlag, [ModSummary]))
 -> m (SuccessFlag, [ModSummary]))
-> (Int -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary])
forall a b. (a -> b) -> a -> b
$ \Int
_ -> do

    -- Sync the global session with the latest HscEnv once the upsweep ends.
    let finallySyncSession :: m a -> m a
finallySyncSession m a
io = m a
io m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`MC.finally` do
            HscEnv
hsc_env <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ MVar HscEnv -> IO HscEnv
forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
            HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env

    m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
finallySyncSession (m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall a b. (a -> b) -> a -> b
$ do

    -- Build the compilation graph out of the list of SCCs. Module cycles are
    -- handled at the very end, after some useful work gets done. Note that
    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).
    (CompilationGraph
comp_graph,Maybe [ModSummary]
cycle) <- IO (CompilationGraph, Maybe [ModSummary])
-> m (CompilationGraph, Maybe [ModSummary])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CompilationGraph, Maybe [ModSummary])
 -> m (CompilationGraph, Maybe [ModSummary]))
-> IO (CompilationGraph, Maybe [ModSummary])
-> m (CompilationGraph, Maybe [ModSummary])
forall a b. (a -> b) -> a -> b
$ [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph [SCC ModSummary]
sccs
    let comp_graph_w_idx :: [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx = CompilationGraph
-> [Int] -> [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip CompilationGraph
comp_graph [Int
1..]

    -- The list of all loops in the compilation graph.
    -- NB: For convenience, the last module of each loop (aka the module that
    -- finishes the loop) is prepended to the beginning of the loop.
    let graph :: [ModSummary]
graph = ((ModSummary, MVar SuccessFlag, LogQueue) -> ModSummary)
-> CompilationGraph -> [ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map (ModSummary, MVar SuccessFlag, LogQueue) -> ModSummary
forall a b c. (a, b, c) -> a
fstOf3 (CompilationGraph -> CompilationGraph
forall a. [a] -> [a]
reverse CompilationGraph
comp_graph)
        boot_modules :: ModuleSet
boot_modules = [Module] -> ModuleSet
mkModuleSet [ModSummary -> Module
ms_mod ModSummary
ms | ModSummary
ms <- [ModSummary]
graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]
        comp_graph_loops :: [[BuildModule]]
comp_graph_loops = [ModSummary] -> ModuleSet -> [[BuildModule]]
go [ModSummary]
graph ModuleSet
boot_modules
          where
            remove :: ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
bm = case ModSummary -> IsBootInterface
isBootSummary ModSummary
ms of
              IsBootInterface
IsBoot -> ModuleSet -> Module -> ModuleSet
delModuleSet ModuleSet
bm (ModSummary -> Module
ms_mod ModSummary
ms)
              IsBootInterface
NotBoot -> ModuleSet
bm
            go :: [ModSummary] -> ModuleSet -> [[BuildModule]]
go [] ModuleSet
_ = []
            go mg :: [ModSummary]
mg@(ModSummary
ms:[ModSummary]
mss) ModuleSet
boot_modules
              | Just [ModSummary]
loop <- ModSummary
-> [ModSummary] -> (Module -> Bool) -> Maybe [ModSummary]
getModLoop ModSummary
ms [ModSummary]
mg (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleSet
boot_modules)
              = (ModSummary -> BuildModule) -> [ModSummary] -> [BuildModule]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> BuildModule
mkBuildModule (ModSummary
msModSummary -> [ModSummary] -> [ModSummary]
forall a. a -> [a] -> [a]
:[ModSummary]
loop) [BuildModule] -> [[BuildModule]] -> [[BuildModule]]
forall a. a -> [a] -> [a]
: [ModSummary] -> ModuleSet -> [[BuildModule]]
go [ModSummary]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)
              | Bool
otherwise
              = [ModSummary] -> ModuleSet -> [[BuildModule]]
go [ModSummary]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)

    -- Build a Map out of the compilation graph with which we can efficiently
    -- look up the result MVar associated with a particular home module.
    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
        home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
home_mod_map =
            [(BuildModule, (MVar SuccessFlag, Int))]
-> Map BuildModule (MVar SuccessFlag, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModSummary -> BuildModule
mkBuildModule ModSummary
ms, (MVar SuccessFlag
mvar, Int
idx))
                         | ((ModSummary
ms,MVar SuccessFlag
mvar,LogQueue
_),Int
idx) <- [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx ]


    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self FilePath
"main --make thread"
    -- For each module in the module graph, spawn a worker thread that will
    -- compile this module.
    let { spawnWorkers :: IO [ThreadId]
spawnWorkers = [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
-> (((ModSummary, MVar SuccessFlag, LogQueue), Int) -> IO ThreadId)
-> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx ((((ModSummary, MVar SuccessFlag, LogQueue), Int) -> IO ThreadId)
 -> IO [ThreadId])
-> (((ModSummary, MVar SuccessFlag, LogQueue), Int) -> IO ThreadId)
-> IO [ThreadId]
forall a b. (a -> b) -> a -> b
$ \((ModSummary
mod,!MVar SuccessFlag
mvar,!LogQueue
log_queue),!Int
mod_idx) ->
            ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords
                    [ FilePath
"worker --make thread"
                    , FilePath
"for module"
                    , FilePath -> FilePath
forall a. Show a => a -> FilePath
show (ModuleName -> FilePath
moduleNameString (ModSummary -> ModuleName
ms_mod_name ModSummary
mod))
                    , FilePath
"number"
                    , Int -> FilePath
forall a. Show a => a -> FilePath
show Int
mod_idx
                    ]
                -- Replace the default log_action with one that writes each
                -- message to the module's log_queue. The main thread will
                -- deal with synchronously printing these messages.
                --
                -- Use a local filesToClean var so that we can clean up
                -- intermediate files in a timely fashion (as soon as
                -- compilation for that module is finished) without having to
                -- worry about accidentally deleting a simultaneous compile's
                -- important files.
                IORef FilesToClean
lcl_files_to_clean <- FilesToClean -> IO (IORef FilesToClean)
forall a. a -> IO (IORef a)
newIORef FilesToClean
emptyFilesToClean
                let lcl_dflags :: DynFlags
lcl_dflags = DynFlags
dflags { log_action :: LogAction
log_action = LogQueue -> LogAction
parLogAction LogQueue
log_queue
                                        , filesToClean :: IORef FilesToClean
filesToClean = IORef FilesToClean
lcl_files_to_clean }

                -- Unmask asynchronous exceptions and perform the thread-local
                -- work to compile the module (see parUpsweep_one).
                Either SomeException SuccessFlag
m_res <- IO SuccessFlag -> IO (Either SomeException SuccessFlag)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (IO SuccessFlag -> IO (Either SomeException SuccessFlag))
-> IO SuccessFlag -> IO (Either SomeException SuccessFlag)
forall a b. (a -> b) -> a -> b
$ IO SuccessFlag -> IO SuccessFlag
forall a. IO a -> IO a
unmask (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors DynFlags
lcl_dflags (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$
                        ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> DynFlags
-> Maybe Messager
-> (HscEnv -> IO ())
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one ModSummary
mod Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops
                                       DynFlags
lcl_dflags Maybe Messager
mHscMessage HscEnv -> IO ()
cleanup
                                       QSem
par_sem MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var
                                       (UniqSet ModuleName, UniqSet ModuleName)
stable_mods Int
mod_idx ([SCC ModSummary] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModSummary]
sccs)

                SuccessFlag
res <- case Either SomeException SuccessFlag
m_res of
                    Right SuccessFlag
flag -> SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
flag
                    Left SomeException
exc -> do
                        -- Don't print ThreadKilled exceptions: they are used
                        -- to kill the worker thread in the event of a user
                        -- interrupt, and the user doesn't have to be informed
                        -- about that.
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc Maybe AsyncException -> Maybe AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
/= AsyncException -> Maybe AsyncException
forall a. a -> Maybe a
Just AsyncException
ThreadKilled)
                             (DynFlags -> SDoc -> IO ()
errorMsg DynFlags
lcl_dflags (FilePath -> SDoc
text (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
exc)))
                        SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed

                -- Populate the result MVar.
                MVar SuccessFlag -> SuccessFlag -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar SuccessFlag
mvar SuccessFlag
res

                -- Write the end marker to the message queue, telling the main
                -- thread that it can stop waiting for messages from this
                -- particular compile.
                LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue Maybe (WarnReason, Severity, SrcSpan, SDoc)
forall a. Maybe a
Nothing

                -- Add the remaining files that weren't cleaned up to the
                -- global filesToClean ref, for cleanup later.
                FilesToClean
                  { ftcCurrentModule :: FilesToClean -> Set FilePath
ftcCurrentModule = Set FilePath
cm_files
                  , ftcGhcSession :: FilesToClean -> Set FilePath
ftcGhcSession = Set FilePath
gs_files
                  } <- IORef FilesToClean -> IO FilesToClean
forall a. IORef a -> IO a
readIORef (DynFlags -> IORef FilesToClean
filesToClean DynFlags
lcl_dflags)
                DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
TFL_CurrentModule ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$ Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
cm_files
                DynFlags -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
TFL_GhcSession ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$ Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
gs_files

        -- Kill all the workers, masking interrupts (since killThread is
        -- interruptible). XXX: This is not ideal.
        ; killWorkers :: [ThreadId] -> IO ()
killWorkers = IO () -> IO ()
forall (m :: * -> *) a. MonadMask m => m a -> m a
MC.uninterruptibleMask_ (IO () -> IO ()) -> ([ThreadId] -> IO ()) -> [ThreadId] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread }


    -- Spawn the workers, making sure to kill them later. Collect the results
    -- of each compile.
    [Maybe ModSummary]
results <- IO [Maybe ModSummary] -> m [Maybe ModSummary]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe ModSummary] -> m [Maybe ModSummary])
-> IO [Maybe ModSummary] -> m [Maybe ModSummary]
forall a b. (a -> b) -> a -> b
$ IO [ThreadId]
-> ([ThreadId] -> IO ())
-> ([ThreadId] -> IO [Maybe ModSummary])
-> IO [Maybe ModSummary]
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO [ThreadId]
spawnWorkers [ThreadId] -> IO ()
killWorkers (([ThreadId] -> IO [Maybe ModSummary]) -> IO [Maybe ModSummary])
-> ([ThreadId] -> IO [Maybe ModSummary]) -> IO [Maybe ModSummary]
forall a b. (a -> b) -> a -> b
$ \[ThreadId]
_ ->
        -- Loop over each module in the compilation graph in order, printing
        -- each message from its log_queue.
        CompilationGraph
-> ((ModSummary, MVar SuccessFlag, LogQueue)
    -> IO (Maybe ModSummary))
-> IO [Maybe ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM CompilationGraph
comp_graph (((ModSummary, MVar SuccessFlag, LogQueue)
  -> IO (Maybe ModSummary))
 -> IO [Maybe ModSummary])
-> ((ModSummary, MVar SuccessFlag, LogQueue)
    -> IO (Maybe ModSummary))
-> IO [Maybe ModSummary]
forall a b. (a -> b) -> a -> b
$ \(ModSummary
mod,MVar SuccessFlag
mvar,LogQueue
log_queue) -> do
            DynFlags -> LogQueue -> IO ()
printLogs DynFlags
dflags LogQueue
log_queue
            SuccessFlag
result <- MVar SuccessFlag -> IO SuccessFlag
forall a. MVar a -> IO a
readMVar MVar SuccessFlag
mvar
            if SuccessFlag -> Bool
succeeded SuccessFlag
result then Maybe ModSummary -> IO (Maybe ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
mod) else Maybe ModSummary -> IO (Maybe ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModSummary
forall a. Maybe a
Nothing


    -- Collect and return the ModSummaries of all the successful compiles.
    -- NB: Reverse this list to maintain output parity with the sequential upsweep.
    let ok_results :: [ModSummary]
ok_results = [ModSummary] -> [ModSummary]
forall a. [a] -> [a]
reverse ([Maybe ModSummary] -> [ModSummary]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModSummary]
results)

    -- Handle any cycle in the original compilation graph and return the result
    -- of the upsweep.
    case Maybe [ModSummary]
cycle of
        Just [ModSummary]
mss -> do
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
fatalErrorMsg DynFlags
dflags ([ModSummary] -> SDoc
cyclicModuleErr [ModSummary]
mss)
            (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed,[ModSummary]
ok_results)
        Maybe [ModSummary]
Nothing  -> do
            let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf ((Maybe ModSummary -> Bool) -> [Maybe ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe ModSummary -> Bool
forall a. Maybe a -> Bool
isJust [Maybe ModSummary]
results)
            (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
success_flag,[ModSummary]
ok_results)

  where
    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,MsgDoc) -> IO ()
    writeLogQueue :: LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue (LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem) Maybe (WarnReason, Severity, SrcSpan, SDoc)
msg = do
        IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
    -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref (([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
  -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)], ()))
 -> IO ())
-> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
    -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)], ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs -> (Maybe (WarnReason, Severity, SrcSpan, SDoc)
msgMaybe (WarnReason, Severity, SrcSpan, SDoc)
-> [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
forall a. a -> [a] -> [a]
:[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs,())
        Bool
_ <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
sem ()
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- The log_action callback that is used to synchronize messages from a
    -- worker thread.
    parLogAction :: LogQueue -> LogAction
    parLogAction :: LogQueue -> LogAction
parLogAction LogQueue
log_queue DynFlags
_dflags !WarnReason
reason !Severity
severity !SrcSpan
srcSpan !SDoc
msg = do
        LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue ((WarnReason, Severity, SrcSpan, SDoc)
-> Maybe (WarnReason, Severity, SrcSpan, SDoc)
forall a. a -> Maybe a
Just (WarnReason
reason,Severity
severity,SrcSpan
srcSpan,SDoc
msg))

    -- Print each message from the log_queue using the log_action from the
    -- session's DynFlags.
    printLogs :: DynFlags -> LogQueue -> IO ()
    printLogs :: DynFlags -> LogQueue -> IO ()
printLogs !DynFlags
dflags (LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem) = IO ()
read_msgs
      where read_msgs :: IO ()
read_msgs = do
                MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
sem
                [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs <- IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
    -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)],
        [Maybe (WarnReason, Severity, SrcSpan, SDoc)]))
-> IO [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref (([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
  -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)],
      [Maybe (WarnReason, Severity, SrcSpan, SDoc)]))
 -> IO [Maybe (WarnReason, Severity, SrcSpan, SDoc)])
-> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)]
    -> ([Maybe (WarnReason, Severity, SrcSpan, SDoc)],
        [Maybe (WarnReason, Severity, SrcSpan, SDoc)]))
-> IO [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
forall a b. (a -> b) -> a -> b
$ \[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs -> ([], [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
-> [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
forall a. [a] -> [a]
reverse [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs)
                [Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs

            print_loop :: [Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [] = IO ()
read_msgs
            print_loop (Maybe (WarnReason, Severity, SrcSpan, SDoc)
x:[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs) = case Maybe (WarnReason, Severity, SrcSpan, SDoc)
x of
                Just (WarnReason
reason,Severity
severity,SrcSpan
srcSpan,SDoc
msg) -> do
                    LogAction
putLogMsg DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
                    [Maybe (WarnReason, Severity, SrcSpan, SDoc)] -> IO ()
print_loop [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs
                -- Exit the loop once we encounter the end marker.
                Maybe (WarnReason, Severity, SrcSpan, SDoc)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- The interruptible subset of the worker threads' work.
parUpsweep_one
    :: ModSummary
    -- ^ The module we wish to compile
    -> Map BuildModule (MVar SuccessFlag, Int)
    -- ^ The map of home modules and their result MVar
    -> [[BuildModule]]
    -- ^ The list of all module loops within the compilation graph.
    -> DynFlags
    -- ^ The thread-local DynFlags
    -> Maybe Messager
    -- ^ The messager
    -> (HscEnv -> IO ())
    -- ^ The callback for cleaning up intermediate files
    -> QSem
    -- ^ The semaphore for limiting the number of simultaneous compiles
    -> MVar HscEnv
    -- ^ The MVar that synchronizes updates to the global HscEnv
    -> IORef HomePackageTable
    -- ^ The old HPT
    -> StableModules
    -- ^ Sets of stable objects and BCOs
    -> Int
    -- ^ The index of this module
    -> Int
    -- ^ The total number of modules
    -> IO SuccessFlag
    -- ^ The result of this compile
parUpsweep_one :: ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> DynFlags
-> Maybe Messager
-> (HscEnv -> IO ())
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one ModSummary
mod Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops DynFlags
lcl_dflags Maybe Messager
mHscMessage HscEnv -> IO ()
cleanup QSem
par_sem
               MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var (UniqSet ModuleName, UniqSet ModuleName)
stable_mods Int
mod_index Int
num_mods = do

    let this_build_mod :: BuildModule
this_build_mod = ModSummary -> BuildModule
mkBuildModule ModSummary
mod

    let home_imps :: [ModuleName]
home_imps     = (GenLocated SrcSpan ModuleName -> ModuleName)
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpan ModuleName] -> [ModuleName])
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
mod
    let home_src_imps :: [ModuleName]
home_src_imps = (GenLocated SrcSpan ModuleName -> ModuleName)
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpan ModuleName] -> [ModuleName])
-> [GenLocated SrcSpan ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
mod

    -- All the textual imports of this module.
    let textual_deps :: Set BuildModule
textual_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList ([BuildModule] -> Set BuildModule)
-> [BuildModule] -> Set BuildModule
forall a b. (a -> b) -> a -> b
$
            (ModuleName -> IsBootInterface -> BuildModule)
-> [ModuleName] -> [IsBootInterface] -> [BuildModule]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> IsBootInterface -> BuildModule
f [ModuleName]
home_imps     (IsBootInterface -> [IsBootInterface]
forall a. a -> [a]
repeat IsBootInterface
NotBoot) [BuildModule] -> [BuildModule] -> [BuildModule]
forall a. [a] -> [a] -> [a]
++
            (ModuleName -> IsBootInterface -> BuildModule)
-> [ModuleName] -> [IsBootInterface] -> [BuildModule]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> IsBootInterface -> BuildModule
f [ModuleName]
home_src_imps (IsBootInterface -> [IsBootInterface]
forall a. a -> [a]
repeat IsBootInterface
IsBoot)
          where f :: ModuleName -> IsBootInterface -> BuildModule
f ModuleName
mn IsBootInterface
isBoot = GWIB :: forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB
                  { gwib_mod :: Module
gwib_mod = DynFlags -> ModuleName -> Module
mkHomeModule DynFlags
lcl_dflags ModuleName
mn
                  , gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
isBoot
                  }

    -- Dealing with module loops
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~
    --
    -- Not only do we have to deal with explicit textual dependencies, we also
    -- have to deal with implicit dependencies introduced by import cycles that
    -- are broken by an hs-boot file. We have to ensure that:
    --
    -- 1. A module that breaks a loop must depend on all the modules in the
    --    loop (transitively or otherwise). This is normally always fulfilled
    --    by the module's textual dependencies except in degenerate loops,
    --    e.g.:
    --
    --    A.hs imports B.hs-boot
    --    B.hs doesn't import A.hs
    --    C.hs imports A.hs, B.hs
    --
    --    In this scenario, getModLoop will detect the module loop [A,B] but
    --    the loop finisher B doesn't depend on A. So we have to explicitly add
    --    A in as a dependency of B when we are compiling B.
    --
    -- 2. A module that depends on a module in an external loop can't proceed
    --    until the entire loop is re-typechecked.
    --
    -- These two invariants have to be maintained to correctly build a
    -- compilation graph with one or more loops.


    -- The loop that this module will finish. After this module successfully
    -- compiles, this loop is going to get re-typechecked.
    let finish_loop :: Maybe [BuildModule]
finish_loop = [[BuildModule]] -> Maybe [BuildModule]
forall a. [a] -> Maybe a
listToMaybe
            [ [BuildModule] -> [BuildModule]
forall a. [a] -> [a]
tail [BuildModule]
loop | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
                        , [BuildModule] -> BuildModule
forall a. [a] -> a
head [BuildModule]
loop BuildModule -> BuildModule -> Bool
forall a. Eq a => a -> a -> Bool
== BuildModule
this_build_mod ]

    -- If this module finishes a loop then it must depend on all the other
    -- modules in that loop because the entire module loop is going to be
    -- re-typechecked once this module gets compiled. These extra dependencies
    -- are this module's "internal" loop dependencies, because this module is
    -- inside the loop in question.
    let int_loop_deps :: Set BuildModule
int_loop_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList ([BuildModule] -> Set BuildModule)
-> [BuildModule] -> Set BuildModule
forall a b. (a -> b) -> a -> b
$
            case Maybe [BuildModule]
finish_loop of
                Maybe [BuildModule]
Nothing   -> []
                Just [BuildModule]
loop -> (BuildModule -> Bool) -> [BuildModule] -> [BuildModule]
forall a. (a -> Bool) -> [a] -> [a]
filter (BuildModule -> BuildModule -> Bool
forall a. Eq a => a -> a -> Bool
/= BuildModule
this_build_mod) [BuildModule]
loop

    -- If this module depends on a module within a loop then it must wait for
    -- that loop to get re-typechecked, i.e. it must wait on the module that
    -- finishes that loop. These extra dependencies are this module's
    -- "external" loop dependencies, because this module is outside of the
    -- loop(s) in question.
    let ext_loop_deps :: Set BuildModule
ext_loop_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList
            [ [BuildModule] -> BuildModule
forall a. [a] -> a
head [BuildModule]
loop | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
                        , (BuildModule -> Bool) -> [BuildModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (BuildModule -> Set BuildModule -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildModule
textual_deps) [BuildModule]
loop
                        , BuildModule
this_build_mod BuildModule -> [BuildModule] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BuildModule]
loop ]


    let all_deps :: Set BuildModule
all_deps = (Set BuildModule -> Set BuildModule -> Set BuildModule)
-> [Set BuildModule] -> Set BuildModule
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Set BuildModule -> Set BuildModule -> Set BuildModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union [Set BuildModule
textual_deps, Set BuildModule
int_loop_deps, Set BuildModule
ext_loop_deps]

    -- All of the module's home-module dependencies.
    let home_deps_with_idx :: [(MVar SuccessFlag, Int)]
home_deps_with_idx =
            [ (MVar SuccessFlag, Int)
home_dep | BuildModule
dep <- Set BuildModule -> [BuildModule]
forall a. Set a -> [a]
Set.toList Set BuildModule
all_deps
                       , Just (MVar SuccessFlag, Int)
home_dep <- [BuildModule
-> Map BuildModule (MVar SuccessFlag, Int)
-> Maybe (MVar SuccessFlag, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BuildModule
dep Map BuildModule (MVar SuccessFlag, Int)
home_mod_map] ]

    -- Sort the list of dependencies in reverse-topological order. This way, by
    -- the time we get woken up by the result of an earlier dependency,
    -- subsequent dependencies are more likely to have finished. This step
    -- effectively reduces the number of MVars that each thread blocks on.
    let home_deps :: [MVar SuccessFlag]
home_deps = ((MVar SuccessFlag, Int) -> MVar SuccessFlag)
-> [(MVar SuccessFlag, Int)] -> [MVar SuccessFlag]
forall a b. (a -> b) -> [a] -> [b]
map (MVar SuccessFlag, Int) -> MVar SuccessFlag
forall a b. (a, b) -> a
fst ([(MVar SuccessFlag, Int)] -> [MVar SuccessFlag])
-> [(MVar SuccessFlag, Int)] -> [MVar SuccessFlag]
forall a b. (a -> b) -> a -> b
$ ((MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering)
-> [(MVar SuccessFlag, Int)] -> [(MVar SuccessFlag, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering)
-> (MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((MVar SuccessFlag, Int) -> Int)
-> (MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (MVar SuccessFlag, Int) -> Int
forall a b. (a, b) -> b
snd)) [(MVar SuccessFlag, Int)]
home_deps_with_idx

    -- Wait for the all the module's dependencies to finish building.
    Bool
deps_ok <- (MVar SuccessFlag -> IO Bool) -> [MVar SuccessFlag] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM ((SuccessFlag -> Bool) -> IO SuccessFlag -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SuccessFlag -> Bool
succeeded (IO SuccessFlag -> IO Bool)
-> (MVar SuccessFlag -> IO SuccessFlag)
-> MVar SuccessFlag
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar SuccessFlag -> IO SuccessFlag
forall a. MVar a -> IO a
readMVar) [MVar SuccessFlag]
home_deps

    -- We can't build this module if any of its dependencies failed to build.
    if Bool -> Bool
not Bool
deps_ok
      then SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
      else do
        -- Any hsc_env at this point is OK to use since we only really require
        -- that the HPT contains the HMIs of our dependencies.
        HscEnv
hsc_env <- MVar HscEnv -> IO HscEnv
forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
        HomePackageTable
old_hpt <- IORef HomePackageTable -> IO HomePackageTable
forall a. IORef a -> IO a
readIORef IORef HomePackageTable
old_hpt_var

        let logger :: SourceError -> IO ()
logger SourceError
err = DynFlags -> ErrorMessages -> IO ()
printBagOfErrors DynFlags
lcl_dflags (SourceError -> ErrorMessages
srcErrorMessages SourceError
err)

        -- Limit the number of parallel compiles.
        let withSem :: QSem -> IO b -> IO b
withSem QSem
sem = IO () -> IO () -> IO b -> IO b
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
MC.bracket_ (QSem -> IO ()
waitQSem QSem
sem) (QSem -> IO ()
signalQSem QSem
sem)
        Maybe HomeModInfo
mb_mod_info <- QSem -> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall {b}. QSem -> IO b -> IO b
withSem QSem
par_sem (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$
            (SourceError -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
err -> do SourceError -> IO ()
logger SourceError
err; Maybe HomeModInfo -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HomeModInfo
forall a. Maybe a
Nothing) (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
                -- Have the ModSummary and HscEnv point to our local log_action
                -- and filesToClean var.
                let lcl_mod :: ModSummary
lcl_mod = ModSummary -> ModSummary
localize_mod ModSummary
mod
                let lcl_hsc_env :: HscEnv
lcl_hsc_env = HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env

                -- Re-typecheck the loop
                -- This is necessary to make sure the knot is tied when
                -- we close a recursive module loop, see bug #12035.
                IORef (NameEnv TyThing)
type_env_var <- IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing)))
-> IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing))
forall a b. (a -> b) -> a -> b
$ NameEnv TyThing -> IO (IORef (NameEnv TyThing))
forall a. a -> IO (IORef a)
newIORef NameEnv TyThing
forall a. NameEnv a
emptyNameEnv
                let lcl_hsc_env' :: HscEnv
lcl_hsc_env' = HscEnv
lcl_hsc_env { hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var =
                                    (Module, IORef (NameEnv TyThing))
-> Maybe (Module, IORef (NameEnv TyThing))
forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
lcl_mod, IORef (NameEnv TyThing)
type_env_var) }
                HscEnv
lcl_hsc_env'' <- case Maybe [BuildModule]
finish_loop of
                    Maybe [BuildModule]
Nothing   -> HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
lcl_hsc_env'
                    -- In the non-parallel case, the retypecheck prior to
                    -- typechecking the loop closer includes all modules
                    -- EXCEPT the loop closer.  However, our precomputed
                    -- SCCs include the loop closer, so we have to filter
                    -- it out.
                    Just [BuildModule]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
lcl_hsc_env' ([ModuleName] -> IO HscEnv) -> [ModuleName] -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
                                 (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (BuildModule -> Module
forall mod. GenWithIsBoot mod -> mod
gwib_mod BuildModule
this_build_mod)) ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
                                 (BuildModule -> ModuleName) -> [BuildModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (BuildModule -> Module) -> BuildModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildModule -> Module
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [BuildModule]
loop

                -- Compile the module.
                HomeModInfo
mod_info <- HscEnv
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
lcl_hsc_env'' Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName, UniqSet ModuleName)
stable_mods
                                        ModSummary
lcl_mod Int
mod_index Int
num_mods
                Maybe HomeModInfo -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
mod_info)

        case Maybe HomeModInfo
mb_mod_info of
            Maybe HomeModInfo
Nothing -> SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
            Just HomeModInfo
mod_info -> do
                let this_mod :: ModuleName
this_mod = ModSummary -> ModuleName
ms_mod_name ModSummary
mod

                -- Prune the old HPT unless this is an hs-boot module.
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ModSummary -> IsBootInterface
isBootSummary ModSummary
mod IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    IORef HomePackageTable
-> (HomePackageTable -> (HomePackageTable, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef HomePackageTable
old_hpt_var ((HomePackageTable -> (HomePackageTable, ())) -> IO ())
-> (HomePackageTable -> (HomePackageTable, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HomePackageTable
old_hpt ->
                        (HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt HomePackageTable
old_hpt ModuleName
this_mod, ())

                -- Update and fetch the global HscEnv.
                HscEnv
lcl_hsc_env' <- MVar HscEnv -> (HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar HscEnv
hsc_env_var ((HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv)
-> (HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
                    let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env
                                     { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
                                                           ModuleName
this_mod HomeModInfo
mod_info }
                    -- We've finished typechecking the module, now we must
                    -- retypecheck the loop AGAIN to ensure unfoldings are
                    -- updated.  This time, however, we include the loop
                    -- closer!
                    HscEnv
hsc_env'' <- case Maybe [BuildModule]
finish_loop of
                        Maybe [BuildModule]
Nothing   -> HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env'
                        Just [BuildModule]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
hsc_env' ([ModuleName] -> IO HscEnv) -> [ModuleName] -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
                                     (BuildModule -> ModuleName) -> [BuildModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (BuildModule -> Module) -> BuildModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildModule -> Module
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [BuildModule]
loop
                    (HscEnv, HscEnv) -> IO (HscEnv, HscEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env'', HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env'')

                -- Clean up any intermediate files.
                HscEnv -> IO ()
cleanup HscEnv
lcl_hsc_env'
                SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded

  where
    localize_mod :: ModSummary -> ModSummary
localize_mod ModSummary
mod
        = ModSummary
mod { ms_hspp_opts :: DynFlags
ms_hspp_opts = (ModSummary -> DynFlags
ms_hspp_opts ModSummary
mod)
                 { log_action :: LogAction
log_action = DynFlags -> LogAction
log_action DynFlags
lcl_dflags
                 , filesToClean :: IORef FilesToClean
filesToClean = DynFlags -> IORef FilesToClean
filesToClean DynFlags
lcl_dflags } }

    localize_hsc_env :: HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env
        = HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                     { log_action :: LogAction
log_action = DynFlags -> LogAction
log_action DynFlags
lcl_dflags
                     , filesToClean :: IORef FilesToClean
filesToClean = DynFlags -> IORef FilesToClean
filesToClean DynFlags
lcl_dflags } }

-- -----------------------------------------------------------------------------
--
-- | The upsweep
--
-- This is where we compile each module in the module graph, in a pass
-- from the bottom to the top of the graph.
--
-- There better had not be any cyclic groups here -- we check for them.
upsweep
    :: GhcMonad m
    => Maybe Messager
    -> HomePackageTable            -- ^ HPT from last time round (pruned)
    -> StableModules               -- ^ stable modules (see checkStability)
    -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files
    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)
    -> m (SuccessFlag,
          [ModSummary])
       -- ^ Returns:
       --
       --  1. A flag whether the complete upsweep was successful.
       --  2. The 'HscEnv' in the monad has an updated HPT
       --  3. A list of modules which succeeded loading.

upsweep :: forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
upsweep Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName, UniqSet ModuleName)
stable_mods HscEnv -> IO ()
cleanup [SCC ModSummary]
sccs = do
   DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
   (SuccessFlag
res, ModuleGraph
done) <- HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
emptyMG [SCC ModSummary]
sccs Int
1 ([SCC ModSummary] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModSummary]
sccs)
                           (DynFlags -> [GenUnit UnitId]
instantiatedUnitsToCheck DynFlags
dflags) UniqSet ModuleName
forall a. UniqSet a
done_holes
   (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
res, [ModSummary] -> [ModSummary]
forall a. [a] -> [a]
reverse ([ModSummary] -> [ModSummary]) -> [ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
done)
 where
  done_holes :: UniqSet a
done_holes = UniqSet a
forall a. UniqSet a
emptyUniqSet

  keep_going :: [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
keep_going [NodeKey]
this_mods HomePackageTable
old_hpt ModuleGraph
done [SCC ModSummary]
mods Int
mod_index Int
nmods [GenUnit UnitId]
uids_to_check UniqSet ModuleName
done_holes = do
    let sum_deps :: [NodeKey] -> SCC ModSummary -> [NodeKey]
sum_deps [NodeKey]
ms (AcyclicSCC ModSummary
mod) =
          if (NodeKey -> Bool) -> [NodeKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((NodeKey -> [NodeKey] -> Bool) -> [NodeKey] -> NodeKey -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip NodeKey -> [NodeKey] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ([NodeKey] -> NodeKey -> Bool) -> [NodeKey] -> NodeKey -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> ModSummary -> [NodeKey]
unfilteredEdges Bool
False ModSummary
mod) [NodeKey]
ms
            then ModSummary -> NodeKey
mkHomeBuildModule ModSummary
modNodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
:[NodeKey]
ms
            else [NodeKey]
ms
        sum_deps [NodeKey]
ms SCC ModSummary
_ = [NodeKey]
ms
        dep_closure :: [NodeKey]
dep_closure = ([NodeKey] -> SCC ModSummary -> [NodeKey])
-> [NodeKey] -> [SCC ModSummary] -> [NodeKey]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [NodeKey] -> SCC ModSummary -> [NodeKey]
sum_deps [NodeKey]
this_mods [SCC ModSummary]
mods
        dropped_ms :: [NodeKey]
dropped_ms = Int -> [NodeKey] -> [NodeKey]
forall a. Int -> [a] -> [a]
drop ([NodeKey] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
this_mods) ([NodeKey] -> [NodeKey]
forall a. [a] -> [a]
reverse [NodeKey]
dep_closure)
        prunable :: SCC ModSummary -> Bool
prunable (AcyclicSCC ModSummary
mod) = NodeKey -> [NodeKey] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ModSummary -> NodeKey
mkHomeBuildModule ModSummary
mod) [NodeKey]
dep_closure
        prunable SCC ModSummary
_ = Bool
False
        mods' :: [SCC ModSummary]
mods' = (SCC ModSummary -> Bool) -> [SCC ModSummary] -> [SCC ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (SCC ModSummary -> Bool) -> SCC ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModSummary -> Bool
prunable) [SCC ModSummary]
mods
        nmods' :: Int
nmods' = Int
nmods Int -> Int -> Int
forall a. Num a => a -> a -> a
- [NodeKey] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
dropped_ms

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [NodeKey] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeKey]
dropped_ms) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
fatalErrorMsg DynFlags
dflags ([ModuleName] -> SDoc
keepGoingPruneErr ([ModuleName] -> SDoc) -> [ModuleName] -> SDoc
forall a b. (a -> b) -> a -> b
$ NodeKey -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod (NodeKey -> ModuleName) -> [NodeKey] -> [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NodeKey]
dropped_ms)
    (SuccessFlag
_, ModuleGraph
done') <- HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
done [SCC ModSummary]
mods' (Int
mod_indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
nmods' [GenUnit UnitId]
uids_to_check UniqSet ModuleName
done_holes
    (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done')

  upsweep'
    :: GhcMonad m
    => HomePackageTable
    -> ModuleGraph
    -> [SCC ModSummary]
    -> Int
    -> Int
    -> [Unit]
    -> UniqSet ModuleName
    -> m (SuccessFlag, ModuleGraph)
  upsweep' :: forall (m :: * -> *).
GhcMonad m =>
HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
_old_hpt ModuleGraph
done
     [] Int
_ Int
_ [GenUnit UnitId]
uids_to_check UniqSet ModuleName
_
   = do HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Hsc () -> IO ()) -> Hsc () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> m ()) -> Hsc () -> m ()
forall a b. (a -> b) -> a -> b
$ (GenUnit UnitId -> Hsc ()) -> [GenUnit UnitId] -> Hsc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO (Messages, Maybe ()) -> Hsc ()
forall a. IO (Messages, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages, Maybe ()) -> Hsc ())
-> (GenUnit UnitId -> IO (Messages, Maybe ()))
-> GenUnit UnitId
-> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> GenUnit UnitId -> IO (Messages, Maybe ())
tcRnCheckUnit HscEnv
hsc_env) [GenUnit UnitId]
uids_to_check
        (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Succeeded, ModuleGraph
done)

  upsweep' HomePackageTable
_old_hpt ModuleGraph
done
     (CyclicSCC [ModSummary]
ms:[SCC ModSummary]
mods) Int
mod_index Int
nmods [GenUnit UnitId]
uids_to_check UniqSet ModuleName
done_holes
   = do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
fatalErrorMsg DynFlags
dflags ([ModSummary] -> SDoc
cyclicModuleErr [ModSummary]
ms)
        if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepGoing DynFlags
dflags
          then [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
forall {m :: * -> *}.
GhcMonad m =>
[NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
keep_going (ModSummary -> NodeKey
mkHomeBuildModule (ModSummary -> NodeKey) -> [ModSummary] -> [NodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModSummary]
ms) HomePackageTable
old_hpt ModuleGraph
done [SCC ModSummary]
mods Int
mod_index Int
nmods
                          [GenUnit UnitId]
uids_to_check UniqSet ModuleName
done_holes
          else (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done)

  upsweep' HomePackageTable
old_hpt ModuleGraph
done
     (AcyclicSCC ModSummary
mod:[SCC ModSummary]
mods) Int
mod_index Int
nmods [GenUnit UnitId]
uids_to_check UniqSet ModuleName
done_holes
   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
        --                     (moduleEnvElts (hsc_HPT hsc_env)))
        let logger :: p -> Maybe SourceError -> m ()
logger p
_mod = Maybe SourceError -> m ()
WarnErrLogger
defaultWarnErrLogger

        HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

        -- TODO: Cache this, so that we don't repeatedly re-check
        -- our imports when you run --make.
        let ([GenUnit UnitId]
ready_uids, [GenUnit UnitId]
uids_to_check')
                = (GenUnit UnitId -> Bool)
-> [GenUnit UnitId] -> ([GenUnit UnitId], [GenUnit UnitId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\GenUnit UnitId
uid -> UniqDSet ModuleName -> Bool
forall a. UniqDSet a -> Bool
isEmptyUniqDSet
                    (GenUnit UnitId -> UniqDSet ModuleName
forall u. GenUnit u -> UniqDSet ModuleName
unitFreeModuleHoles GenUnit UnitId
uid UniqDSet ModuleName -> UniqSet ModuleName -> UniqDSet ModuleName
forall a. UniqDSet a -> UniqSet a -> UniqDSet a
`uniqDSetMinusUniqSet` UniqSet ModuleName
done_holes))
                     [GenUnit UnitId]
uids_to_check
            done_holes' :: UniqSet ModuleName
done_holes'
                | ModSummary -> HscSource
ms_hsc_src ModSummary
mod HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
                = UniqSet ModuleName -> ModuleName -> UniqSet ModuleName
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet ModuleName
done_holes (ModSummary -> ModuleName
ms_mod_name ModSummary
mod)
                | Bool
otherwise = UniqSet ModuleName
done_holes
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Hsc () -> IO ()) -> Hsc () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> m ()) -> Hsc () -> m ()
forall a b. (a -> b) -> a -> b
$ (GenUnit UnitId -> Hsc ()) -> [GenUnit UnitId] -> Hsc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO (Messages, Maybe ()) -> Hsc ()
forall a. IO (Messages, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages, Maybe ()) -> Hsc ())
-> (GenUnit UnitId -> IO (Messages, Maybe ()))
-> GenUnit UnitId
-> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> GenUnit UnitId -> IO (Messages, Maybe ())
tcRnCheckUnit HscEnv
hsc_env) [GenUnit UnitId]
ready_uids

        -- Remove unwanted tmp files between compilations
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> IO ()
cleanup HscEnv
hsc_env)

        -- Get ready to tie the knot
        IORef (NameEnv TyThing)
type_env_var <- IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing)))
-> IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing))
forall a b. (a -> b) -> a -> b
$ NameEnv TyThing -> IO (IORef (NameEnv TyThing))
forall a. a -> IO (IORef a)
newIORef NameEnv TyThing
forall a. NameEnv a
emptyNameEnv
        let hsc_env1 :: HscEnv
hsc_env1 = HscEnv
hsc_env { hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var =
                                    (Module, IORef (NameEnv TyThing))
-> Maybe (Module, IORef (NameEnv TyThing))
forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
mod, IORef (NameEnv TyThing)
type_env_var) }
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env1

        -- Lazily reload the HPT modules participating in the loop.
        -- See Note [Tying the knot]--if we don't throw out the old HPT
        -- and reinitalize the knot-tying process, anything that was forced
        -- while we were previously typechecking won't get updated, this
        -- was bug #12035.
        HscEnv
hsc_env2 <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env1 ModSummary
mod ModuleGraph
done
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env2

        Maybe HomeModInfo
mb_mod_info
            <- (SourceError -> m (Maybe HomeModInfo))
-> m (Maybe HomeModInfo) -> m (Maybe HomeModInfo)
forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError
                   (\SourceError
err -> do ModSummary -> Maybe SourceError -> m ()
forall {m :: * -> *} {p}.
GhcMonad m =>
p -> Maybe SourceError -> m ()
logger ModSummary
mod (SourceError -> Maybe SourceError
forall a. a -> Maybe a
Just SourceError
err); Maybe HomeModInfo -> m (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HomeModInfo
forall a. Maybe a
Nothing) (m (Maybe HomeModInfo) -> m (Maybe HomeModInfo))
-> m (Maybe HomeModInfo) -> m (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
                 HomeModInfo
mod_info <- IO HomeModInfo -> m HomeModInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomeModInfo -> m HomeModInfo)
-> IO HomeModInfo -> m HomeModInfo
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env2 Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName, UniqSet ModuleName)
stable_mods
                                                  ModSummary
mod Int
mod_index Int
nmods
                 ModSummary -> Maybe SourceError -> m ()
forall {m :: * -> *} {p}.
GhcMonad m =>
p -> Maybe SourceError -> m ()
logger ModSummary
mod Maybe SourceError
forall a. Maybe a
Nothing -- log warnings
                 Maybe HomeModInfo -> m (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
mod_info)

        case Maybe HomeModInfo
mb_mod_info of
          Maybe HomeModInfo
Nothing -> do
                DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
                if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepGoing DynFlags
dflags
                  then [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
forall {m :: * -> *}.
GhcMonad m =>
[NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
keep_going [ModSummary -> NodeKey
mkHomeBuildModule ModSummary
mod] HomePackageTable
old_hpt ModuleGraph
done [SCC ModSummary]
mods Int
mod_index Int
nmods
                                  [GenUnit UnitId]
uids_to_check UniqSet ModuleName
done_holes
                  else (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done)
          Just HomeModInfo
mod_info -> do
                let this_mod :: ModuleName
this_mod = ModSummary -> ModuleName
ms_mod_name ModSummary
mod

                        -- Add new info to hsc_env
                    hpt1 :: HomePackageTable
hpt1     = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env2) ModuleName
this_mod HomeModInfo
mod_info
                    hsc_env3 :: HscEnv
hsc_env3 = HscEnv
hsc_env2 { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
hpt1, hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var = Maybe (Module, IORef (NameEnv TyThing))
forall a. Maybe a
Nothing }

                        -- Space-saving: delete the old HPT entry
                        -- for mod BUT if mod is a hs-boot
                        -- node, don't delete it.  For the
                        -- interface, the HPT entry is probably for the
                        -- main Haskell source file.  Deleting it
                        -- would force the real module to be recompiled
                        -- every time.
                    old_hpt1 :: HomePackageTable
old_hpt1 = case ModSummary -> IsBootInterface
isBootSummary ModSummary
mod of
                      IsBootInterface
IsBoot -> HomePackageTable
old_hpt
                      IsBootInterface
NotBoot -> HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt HomePackageTable
old_hpt ModuleName
this_mod

                    done' :: ModuleGraph
done' = ModuleGraph -> ModSummary -> ModuleGraph
extendMG ModuleGraph
done ModSummary
mod

                        -- fixup our HomePackageTable after we've finished compiling
                        -- a mutually-recursive loop.  We have to do this again
                        -- to make sure we have the final unfoldings, which may
                        -- not have been computed accurately in the previous
                        -- retypecheck.
                HscEnv
hsc_env4 <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env3 ModSummary
mod ModuleGraph
done'
                HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env4

                        -- Add any necessary entries to the static pointer
                        -- table. See Note [Grand plan for static forms] in
                        -- GHC.Iface.Tidy.StaticPtrTable.
                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> HscTarget
hscTarget (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env4) HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env4
                                 [ SptEntry
spt
                                 | Just Linkable
linkable <- Maybe Linkable -> [Maybe Linkable]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Linkable -> [Maybe Linkable])
-> Maybe Linkable -> [Maybe Linkable]
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
mod_info
                                 , Unlinked
unlinked <- Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
                                 , BCOs CompiledByteCode
_ [SptEntry]
spts <- Unlinked -> [Unlinked]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unlinked
unlinked
                                 , SptEntry
spt <- [SptEntry]
spts
                                 ]

                HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [GenUnit UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt1 ModuleGraph
done' [SCC ModSummary]
mods (Int
mod_indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
nmods [GenUnit UnitId]
uids_to_check' UniqSet ModuleName
done_holes'

-- | Return a list of instantiated units to type check from the UnitState.
--
-- Use explicit (instantiated) units as roots and also return their
-- instantiations that are themselves instantiations and so on recursively.
instantiatedUnitsToCheck :: DynFlags -> [Unit]
instantiatedUnitsToCheck :: DynFlags -> [GenUnit UnitId]
instantiatedUnitsToCheck DynFlags
dflags =
  [GenUnit UnitId] -> [GenUnit UnitId]
forall a. Ord a => [a] -> [a]
nubSort ([GenUnit UnitId] -> [GenUnit UnitId])
-> [GenUnit UnitId] -> [GenUnit UnitId]
forall a b. (a -> b) -> a -> b
$ (GenUnit UnitId -> [GenUnit UnitId])
-> [GenUnit UnitId] -> [GenUnit UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenUnit UnitId -> [GenUnit UnitId]
forall {unit}. GenUnit unit -> [GenUnit unit]
goUnit (UnitState -> [GenUnit UnitId]
explicitUnits (DynFlags -> UnitState
unitState DynFlags
dflags))
 where
  goUnit :: GenUnit unit -> [GenUnit unit]
goUnit GenUnit unit
HoleUnit         = []
  goUnit (RealUnit Definite unit
_)     = []
  goUnit uid :: GenUnit unit
uid@(VirtUnit GenInstantiatedUnit unit
i) = GenUnit unit
uid GenUnit unit -> [GenUnit unit] -> [GenUnit unit]
forall a. a -> [a] -> [a]
: ((ModuleName, GenModule (GenUnit unit)) -> [GenUnit unit])
-> [(ModuleName, GenModule (GenUnit unit))] -> [GenUnit unit]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenUnit unit -> [GenUnit unit]
goUnit (GenUnit unit -> [GenUnit unit])
-> ((ModuleName, GenModule (GenUnit unit)) -> GenUnit unit)
-> (ModuleName, GenModule (GenUnit unit))
-> [GenUnit unit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule (GenUnit unit) -> GenUnit unit
forall unit. GenModule unit -> unit
moduleUnit (GenModule (GenUnit unit) -> GenUnit unit)
-> ((ModuleName, GenModule (GenUnit unit))
    -> GenModule (GenUnit unit))
-> (ModuleName, GenModule (GenUnit unit))
-> GenUnit unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, GenModule (GenUnit unit)) -> GenModule (GenUnit unit)
forall a b. (a, b) -> b
snd) (GenInstantiatedUnit unit
-> [(ModuleName, GenModule (GenUnit unit))]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit unit
i)

maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
location
 | DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags
    -- Minor optimization: it should be harmless to check the hi file location
    -- always, but it's better to avoid hitting the filesystem if possible.
    = FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
 | Bool
otherwise
    = Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing

-- | 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
            -> HomePackageTable
            -> StableModules
            -> ModSummary
            -> Int  -- index of module
            -> Int  -- total number of modules
            -> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco) ModSummary
summary Int
mod_index Int
nmods
   =    let
            this_mod_name :: ModuleName
this_mod_name = ModSummary -> ModuleName
ms_mod_name ModSummary
summary
            this_mod :: Module
this_mod    = ModSummary -> Module
ms_mod ModSummary
summary
            mb_obj_date :: Maybe UTCTime
mb_obj_date = ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
summary
            mb_if_date :: Maybe UTCTime
mb_if_date  = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
summary
            obj_fn :: FilePath
obj_fn      = ModLocation -> FilePath
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
            hs_date :: UTCTime
hs_date     = ModSummary -> UTCTime
ms_hs_date ModSummary
summary

            is_stable_obj :: Bool
is_stable_obj = ModuleName
this_mod_name ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj
            is_stable_bco :: Bool
is_stable_bco = ModuleName
this_mod_name ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco

            old_hmi :: Maybe HomeModInfo
old_hmi = HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt ModuleName
this_mod_name

            -- We're using the dflags for this module now, obtained by
            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
            dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary
            prevailing_target :: HscTarget
prevailing_target = DynFlags -> HscTarget
hscTarget (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
            local_target :: HscTarget
local_target      = DynFlags -> HscTarget
hscTarget DynFlags
dflags

            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
            -- we don't do anything dodgy: these should only work to change
            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,
            -- otherwise we could end up trying to link object code to byte
            -- code.
            target :: HscTarget
target = if HscTarget
prevailing_target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
local_target
                        Bool -> Bool -> Bool
&& (Bool -> Bool
not (HscTarget -> Bool
isObjectTarget HscTarget
prevailing_target)
                            Bool -> Bool -> Bool
|| Bool -> Bool
not (HscTarget -> Bool
isObjectTarget HscTarget
local_target))
                        Bool -> Bool -> Bool
&& Bool -> Bool
not (HscTarget
prevailing_target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing)
                        Bool -> Bool -> Bool
&& Bool -> Bool
not (HscTarget
prevailing_target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted)
                        then HscTarget
prevailing_target
                        else HscTarget
local_target

            -- store the corrected hscTarget into the summary
            summary' :: ModSummary
summary' = ModSummary
summary{ ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags { hscTarget :: HscTarget
hscTarget = HscTarget
target } }

            -- The old interface is ok if
            --  a) we're compiling a source file, and the old HPT
            --     entry is for a source file
            --  b) we're compiling a hs-boot file
            -- Case (b) allows an hs-boot file to get the interface of its
            -- real source file on the second iteration of the compilation
            -- manager, but that does no harm.  Otherwise the hs-boot file
            -- will always be recompiled

            mb_old_iface :: Maybe (ModIface_ 'ModIfaceFinal)
mb_old_iface
                = case Maybe HomeModInfo
old_hmi of
                     Maybe HomeModInfo
Nothing                                        -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. Maybe a
Nothing
                     Just HomeModInfo
hm_info | ModSummary -> IsBootInterface
isBootSummary ModSummary
summary IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot -> ModIface_ 'ModIfaceFinal -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. a -> Maybe a
Just ModIface_ 'ModIfaceFinal
iface
                                  | ModIface_ 'ModIfaceFinal -> IsBootInterface
mi_boot ModIface_ 'ModIfaceFinal
iface IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot        -> ModIface_ 'ModIfaceFinal -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. a -> Maybe a
Just ModIface_ 'ModIfaceFinal
iface
                                  | Bool
otherwise                       -> Maybe (ModIface_ 'ModIfaceFinal)
forall a. Maybe a
Nothing
                                   where
                                     iface :: ModIface_ 'ModIfaceFinal
iface = HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hm_info

            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it  Maybe Linkable
mb_linkable SourceModified
src_modified =
                  Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe (ModIface_ 'ModIfaceFinal)
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
                             Maybe (ModIface_ 'ModIfaceFinal)
mb_old_iface Maybe Linkable
mb_linkable SourceModified
src_modified

            compile_it_discard_iface :: Maybe Linkable -> SourceModified
                                     -> IO HomeModInfo
            compile_it_discard_iface :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it_discard_iface Maybe Linkable
mb_linkable  SourceModified
src_modified =
                  Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe (ModIface_ 'ModIfaceFinal)
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
                             Maybe (ModIface_ 'ModIfaceFinal)
forall a. Maybe a
Nothing Maybe Linkable
mb_linkable SourceModified
src_modified

            -- With the HscNothing target we create empty linkables to avoid
            -- recompilation.  We have to detect these to recompile anyway if
            -- the target changed since the last compile.
            is_fake_linkable :: Bool
is_fake_linkable
               | Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi, Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi =
                  [Unlinked] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Linkable -> [Unlinked]
linkableUnlinked Linkable
l)
               | Bool
otherwise =
                   -- we have no linkable, so it cannot be fake
                   Bool
False

            implies :: Bool -> Bool -> Bool
implies Bool
False Bool
_ = Bool
True
            implies Bool
True Bool
x  = Bool
x

        in
        case () of
         ()
_
                -- Regardless of whether we're generating object code or
                -- byte code, we can always use an existing object file
                -- if it is *stable* (see checkStability).
          | Bool
is_stable_obj, Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi -> do
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
5
                           (FilePath -> SDoc
text FilePath
"skipping stable obj mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
                -- object is stable, and we have an entry in the
                -- old HPT: nothing to do

          | Bool
is_stable_obj, Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe HomeModInfo
old_hmi -> do
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
5
                           (FilePath -> SDoc
text FilePath
"compiling stable on-disk mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Linkable
linkable <- IO Linkable -> IO Linkable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Linkable -> IO Linkable) -> IO Linkable -> IO Linkable
forall a b. (a -> b) -> a -> b
$ Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod FilePath
obj_fn
                              (FilePath -> Maybe UTCTime -> UTCTime
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"upsweep1" Maybe UTCTime
mb_obj_date)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodifiedAndStable
                -- object is stable, but we need to load the interface
                -- off disk to make a HMI.

          | Bool -> Bool
not (HscTarget -> Bool
isObjectTarget HscTarget
target), Bool
is_stable_bco,
            (HscTarget
target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
HscNothing) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable ->
                ASSERT(isJust old_hmi) -- must be in the old_hpt
                let Just HomeModInfo
hmi = Maybe HomeModInfo
old_hmi in do
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
5
                           (FilePath -> SDoc
text FilePath
"skipping stable BCO mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
                -- BCO is stable: nothing to do

          | Bool -> Bool
not (HscTarget -> Bool
isObjectTarget HscTarget
target),
            Just HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi,
            Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
            Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
l),
            (HscTarget
target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
HscNothing) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable,
            Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
summary -> do
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
5
                           (FilePath -> SDoc
text FilePath
"compiling non-stable BCO mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
                -- we have an old BCO that is up to date with respect
                -- to the source: do a recompilation check as normal.

          -- When generating object code, if there's an up-to-date
          -- object file on the disk, then we can use it.
          -- However, if the object file is new (compared to any
          -- linkable we had from a previous compilation), then we
          -- must discard any in-memory interface, because this
          -- means the user has compiled the source file
          -- separately and generated a new interface, that we must
          -- read from the disk.
          --
          | HscTarget -> Bool
isObjectTarget HscTarget
target,
            Just UTCTime
obj_date <- Maybe UTCTime
mb_obj_date,
            UTCTime
obj_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
hs_date -> do
                case Maybe HomeModInfo
old_hmi of
                  Just HomeModInfo
hmi
                    | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
                      Linkable -> Bool
isObjectLinkable Linkable
l Bool -> Bool -> Bool
&& Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
obj_date -> do
                          IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
5
                                     (FilePath -> SDoc
text FilePath
"compiling mod with new on-disk obj:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                          Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
                  Maybe HomeModInfo
_otherwise -> do
                          IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
5
                                     (FilePath -> SDoc
text FilePath
"compiling mod with new on-disk obj2:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                          Linkable
linkable <- IO Linkable -> IO Linkable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Linkable -> IO Linkable) -> IO Linkable -> IO Linkable
forall a b. (a -> b) -> a -> b
$ Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod FilePath
obj_fn UTCTime
obj_date
                          Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it_discard_iface (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodified

          -- See Note [Recompilation checking in -fno-code mode]
          | DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags,
            Just UTCTime
if_date <- Maybe UTCTime
mb_if_date,
            UTCTime
if_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
hs_date -> do
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
5
                           (FilePath -> SDoc
text FilePath
"skipping tc'd mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it Maybe Linkable
forall a. Maybe a
Nothing SourceModified
SourceUnmodified

         ()
_otherwise -> do
                IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
5
                           (FilePath -> SDoc
text FilePath
"compiling mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it Maybe Linkable
forall a. Maybe a
Nothing SourceModified
SourceModified


{- 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
hscTarget == HscNothing.

-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 [Recompilation checking in -fno-code mode]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- If we are compiling with -fno-code -fwrite-interface, there won't
-- be any object code that we can compare against, nor should there
-- be: we're *just* generating interface files.  In this case, we
-- want to check if the interface file is new, in lieu of the object
-- file.  See also #9243.

-- Filter modules in the HPT
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs [ModuleName]
keep_these HomePackageTable
hpt
   = [(ModuleName, HomeModInfo)] -> HomePackageTable
listToHpt   [ (ModuleName
mod, FilePath -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"retain" Maybe HomeModInfo
mb_mod_info)
                 | ModuleName
mod <- [ModuleName]
keep_these
                 , let mb_mod_info :: Maybe HomeModInfo
mb_mod_info = HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
mod
                 , Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isJust Maybe HomeModInfo
mb_mod_info ]

-- ---------------------------------------------------------------------------
-- Typecheck module loops
{-
See bug #930.  This code fixes a long-standing bug in --make.  The
problem is that when compiling the modules *inside* a loop, a data
type that is only defined at the top of the loop looks opaque; but
after the loop is done, the structure of the data type becomes
apparent.

The difficulty is then that two different bits of code have
different notions of what the data type looks like.

The idea is that after we compile a module which also has an .hs-boot
file, we re-generate the ModDetails for each of the modules that
depends on the .hs-boot file, so that everyone points to the proper
TyCons, Ids etc. defined by the real module, not the boot module.
Fortunately re-generating a ModDetails from a ModIface is easy: the
function GHC.IfaceToCore.typecheckIface does exactly that.

Picking the modules to re-typecheck is slightly tricky.  Starting from
the module graph consisting of the modules that have already been
compiled, we reverse the edges (so they point from the imported module
to the importing module), and depth-first-search from the .hs-boot
node.  This gives us all the modules that depend transitively on the
.hs-boot module, and those are exactly the modules that we need to
re-typecheck.

Following this fix, GHC can compile itself with --make -O2.
-}

reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env ModSummary
ms ModuleGraph
graph
  | Just [ModSummary]
loop <- ModSummary
-> [ModSummary] -> (Module -> Bool) -> Maybe [ModSummary]
getModLoop ModSummary
ms [ModSummary]
mss Module -> Bool
appearsAsBoot
  -- SOME hs-boot files should still
  -- get used, just not the loop-closer.
  , let non_boot :: [ModSummary]
non_boot = (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
l -> Bool -> Bool
not (ModSummary -> IsBootInterface
isBootSummary ModSummary
l IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot Bool -> Bool -> Bool
&&
                                 ModSummary -> Module
ms_mod ModSummary
l Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> Module
ms_mod ModSummary
ms)) [ModSummary]
loop
  = DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) HscEnv
hsc_env ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
non_boot)
  | Bool
otherwise
  = HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
  where
  mss :: [ModSummary]
mss = ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
graph
  appearsAsBoot :: Module -> Bool
appearsAsBoot = (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleGraph -> ModuleSet
mgBootModules ModuleGraph
graph)

-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a
-- corresponding boot file in @graph@, return the set of modules which
-- transitively depend on this boot file.  This function is slightly misnamed,
-- but its name "getModLoop" alludes to the fact that, when getModLoop is called
-- with a graph that does not contain @ms@ (non-parallel case) or is an
-- SCC with hs-boot nodes dropped (parallel-case), the modules which
-- depend on the hs-boot file are typically (but not always) the
-- modules participating in the recursive module loop.  The returned
-- list includes the hs-boot file.
--
-- Example:
--      let g represent the module graph:
--          C.hs
--          A.hs-boot imports C.hs
--          B.hs imports A.hs-boot
--          A.hs imports B.hs
--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]
--
--      It would also be permissible to omit A.hs from the graph,
--      in which case the result is [A.hs-boot, B.hs]
--
-- Example:
--      A counter-example to the claim that modules returned
--      by this function participate in the loop occurs here:
--
--      let g represent the module graph:
--          C.hs
--          A.hs-boot imports C.hs
--          B.hs imports A.hs-boot
--          A.hs imports B.hs
--          D.hs imports A.hs-boot
--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]
--
--      Arguably, D.hs should import A.hs, not A.hs-boot, but
--      a dependency on the boot file is not illegal.
--
getModLoop
  :: ModSummary
  -> [ModSummary]
  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'
  -> Maybe [ModSummary]
getModLoop :: ModSummary
-> [ModSummary] -> (Module -> Bool) -> Maybe [ModSummary]
getModLoop ModSummary
ms [ModSummary]
graph Module -> Bool
appearsAsBoot
  | ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot
  , Module -> Bool
appearsAsBoot Module
this_mod
  , let mss :: [ModSummary]
mss = ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) [ModSummary]
graph
  = [ModSummary] -> Maybe [ModSummary]
forall a. a -> Maybe a
Just [ModSummary]
mss
  | Bool
otherwise
  = Maybe [ModSummary]
forall a. Maybe a
Nothing
 where
  this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
ms

-- NB: sometimes mods has duplicates; this is harmless because
-- any duplicates get clobbered in addListToHpt and never get forced.
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
dflags HscEnv
hsc_env [ModuleName]
mods = do
  DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
     FilePath -> SDoc
text FilePath
"Re-typechecking loop: " SDoc -> SDoc -> SDoc
<> [ModuleName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
mods
  HomePackageTable
new_hpt <-
    (HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable
forall a. (a -> IO a) -> IO a
fixIO ((HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable)
-> (HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable
forall a b. (a -> b) -> a -> b
$ \HomePackageTable
new_hpt -> do
      let new_hsc_env :: HscEnv
new_hsc_env = HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
      [ModDetails]
mds <- SDoc -> HscEnv -> IfG [ModDetails] -> IO [ModDetails]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
text FilePath
"typecheckLoop") HscEnv
new_hsc_env (IfG [ModDetails] -> IO [ModDetails])
-> IfG [ModDetails] -> IO [ModDetails]
forall a b. (a -> b) -> a -> b
$
                (HomeModInfo -> IOEnv (Env IfGblEnv ()) ModDetails)
-> [HomeModInfo] -> IfG [ModDetails]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModIface_ 'ModIfaceFinal -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface (ModIface_ 'ModIfaceFinal -> IOEnv (Env IfGblEnv ()) ModDetails)
-> (HomeModInfo -> ModIface_ 'ModIfaceFinal)
-> HomeModInfo
-> IOEnv (Env IfGblEnv ()) ModDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface) [HomeModInfo]
hmis
      let new_hpt :: HomePackageTable
new_hpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt HomePackageTable
old_hpt
                        ([ModuleName] -> [HomeModInfo] -> [(ModuleName, HomeModInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
mods [ HomeModInfo
hmi{ hm_details :: ModDetails
hm_details = ModDetails
details }
                                  | (HomeModInfo
hmi,ModDetails
details) <- [HomeModInfo] -> [ModDetails] -> [(HomeModInfo, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds ])
      HomePackageTable -> IO HomePackageTable
forall (m :: * -> *) a. Monad m => a -> m a
return HomePackageTable
new_hpt
  HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
  where
    old_hpt :: HomePackageTable
old_hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    hmis :: [HomeModInfo]
hmis    = (ModuleName -> HomeModInfo) -> [ModuleName] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"typecheckLoop" (Maybe HomeModInfo -> HomeModInfo)
-> (ModuleName -> Maybe HomeModInfo) -> ModuleName -> HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt) [ModuleName]
mods

reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards ModuleName
mod [ModSummary]
summaries
  = [ Node Int ModSummary -> ModSummary
forall key payload. Node key payload -> payload
node_payload Node Int ModSummary
node | Node Int ModSummary
node <- Graph (Node Int ModSummary)
-> Node Int ModSummary -> [Node Int ModSummary]
forall node. Graph node -> node -> [node]
reachableG (Graph (Node Int ModSummary) -> Graph (Node Int ModSummary)
forall node. Graph node -> Graph node
transposeG Graph (Node Int ModSummary)
graph) Node Int ModSummary
root ]
  where -- the rest just sets up the graph:
        (Graph (Node Int ModSummary)
graph, NodeKey -> Maybe (Node Int ModSummary)
lookup_node) = Bool
-> [ModSummary]
-> (Graph (Node Int ModSummary),
    NodeKey -> Maybe (Node Int ModSummary))
moduleGraphNodes Bool
False [ModSummary]
summaries
        root :: Node Int ModSummary
root  = FilePath -> Maybe (Node Int ModSummary) -> Node Int ModSummary
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"reachableBackwards" (NodeKey -> Maybe (Node Int ModSummary)
lookup_node (NodeKey -> Maybe (Node Int ModSummary))
-> NodeKey -> Maybe (Node Int ModSummary)
forall a b. (a -> b) -> a -> b
$ ModuleName -> IsBootInterface -> NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mod IsBootInterface
IsBoot)

-- ---------------------------------------------------------------------------
--
-- | Topological sort of the module graph
topSortModuleGraph
          :: Bool
          -- ^ Drop hi-boot nodes? (see below)
          -> ModuleGraph
          -> Maybe ModuleName
             -- ^ Root module name.  If @Nothing@, use the full graph.
          -> [SCC ModSummary]
-- ^ 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 ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
drop_hs_boot_nodes ModuleGraph
module_graph Maybe ModuleName
mb_root_mod
  = (SCC (Node Int ModSummary) -> SCC ModSummary)
-> [SCC (Node Int ModSummary)] -> [SCC ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map ((Node Int ModSummary -> ModSummary)
-> SCC (Node Int ModSummary) -> SCC ModSummary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node Int ModSummary -> ModSummary
summaryNodeSummary) ([SCC (Node Int ModSummary)] -> [SCC ModSummary])
-> [SCC (Node Int ModSummary)] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$ Graph (Node Int ModSummary) -> [SCC (Node Int ModSummary)]
forall node. Graph node -> [SCC node]
stronglyConnCompG Graph (Node Int ModSummary)
initial_graph
  where
    summaries :: [ModSummary]
summaries = ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
module_graph
    -- stronglyConnCompG flips the original order, so if we reverse
    -- the summaries we get a stable topological sort.
    (Graph (Node Int ModSummary)
graph, NodeKey -> Maybe (Node Int ModSummary)
lookup_node) =
      Bool
-> [ModSummary]
-> (Graph (Node Int ModSummary),
    NodeKey -> Maybe (Node Int ModSummary))
moduleGraphNodes Bool
drop_hs_boot_nodes ([ModSummary] -> [ModSummary]
forall a. [a] -> [a]
reverse [ModSummary]
summaries)

    initial_graph :: Graph (Node Int ModSummary)
initial_graph = case Maybe ModuleName
mb_root_mod of
        Maybe ModuleName
Nothing -> Graph (Node Int ModSummary)
graph
        Just 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 :: Node Int ModSummary
root | Just Node Int ModSummary
node <- NodeKey -> Maybe (Node Int ModSummary)
lookup_node (NodeKey -> Maybe (Node Int ModSummary))
-> NodeKey -> Maybe (Node Int ModSummary)
forall a b. (a -> b) -> a -> b
$ ModuleName -> IsBootInterface -> NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
root_mod IsBootInterface
NotBoot
                     , Graph (Node Int ModSummary)
graph Graph (Node Int ModSummary) -> Node Int ModSummary -> Bool
forall node. Graph node -> node -> Bool
`hasVertexG` Node Int ModSummary
node
                     = Node Int ModSummary
node
                     | Bool
otherwise
                     = GhcException -> Node Int ModSummary
forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
ProgramError FilePath
"module does not exist")
            in [Node Int ModSummary] -> Graph (Node Int ModSummary)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (Node Int ModSummary
-> [Node Int ModSummary] -> [Node Int ModSummary]
seq Node Int ModSummary
root (Graph (Node Int ModSummary)
-> Node Int ModSummary -> [Node Int ModSummary]
forall node. Graph node -> node -> [node]
reachableG Graph (Node Int ModSummary)
graph Node Int ModSummary
root))

type SummaryNode = Node Int ModSummary

summaryNodeKey :: SummaryNode -> Int
summaryNodeKey :: Node Int ModSummary -> Int
summaryNodeKey = Node Int ModSummary -> Int
forall key payload. Node key payload -> key
node_key

summaryNodeSummary :: SummaryNode -> ModSummary
summaryNodeSummary :: Node Int ModSummary -> ModSummary
summaryNodeSummary = Node Int ModSummary -> ModSummary
forall key payload. Node key payload -> payload
node_payload

unfilteredEdges :: Bool -> ModSummary -> [ModuleNameWithIsBoot]
unfilteredEdges :: Bool -> ModSummary -> [NodeKey]
unfilteredEdges Bool
drop_hs_boot_nodes ModSummary
ms =
    ((ModuleName -> IsBootInterface -> NodeKey)
-> IsBootInterface -> ModuleName -> NodeKey
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleName -> IsBootInterface -> NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
hs_boot_key (ModuleName -> NodeKey)
-> (GenLocated SrcSpan ModuleName -> ModuleName)
-> GenLocated SrcSpan ModuleName
-> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> NodeKey)
-> [GenLocated SrcSpan ModuleName] -> [NodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
ms) [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++
    ((ModuleName -> IsBootInterface -> NodeKey)
-> IsBootInterface -> ModuleName -> NodeKey
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleName -> IsBootInterface -> NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
NotBoot     (ModuleName -> NodeKey)
-> (GenLocated SrcSpan ModuleName -> ModuleName)
-> GenLocated SrcSpan ModuleName
-> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> NodeKey)
-> [GenLocated SrcSpan ModuleName] -> [NodeKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
ms) [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++
    [ ModuleName -> IsBootInterface -> NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
drop_hs_boot_nodes Bool -> Bool -> Bool
|| ModSummary -> HscSource
ms_hsc_src ModSummary
ms HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
      -- see [boot-edges] below
    ]
  where
    -- [boot-edges] if this is a .hs and there is an equivalent
    -- .hs-boot, add a link from the former to the latter.  This
    -- has the effect of detecting bogus cases where the .hs-boot
    -- depends on the .hs, by introducing a cycle.  Additionally,
    -- it ensures that we will always process the .hs-boot before
    -- the .hs, and so the HomePackageTable will always have the
    -- most up to date information.

    -- Drop hs-boot nodes by using HsSrcFile as the key
    hs_boot_key :: IsBootInterface
hs_boot_key | Bool
drop_hs_boot_nodes = IsBootInterface
NotBoot -- is regular mod or signature
                | Bool
otherwise          = IsBootInterface
IsBoot

moduleGraphNodes :: Bool -> [ModSummary]
  -> (Graph SummaryNode, ModuleNameWithIsBoot -> Maybe SummaryNode)
moduleGraphNodes :: Bool
-> [ModSummary]
-> (Graph (Node Int ModSummary),
    NodeKey -> Maybe (Node Int ModSummary))
moduleGraphNodes Bool
drop_hs_boot_nodes [ModSummary]
summaries =
  ([Node Int ModSummary] -> Graph (Node Int ModSummary)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [Node Int ModSummary]
nodes, NodeKey -> Maybe (Node Int ModSummary)
lookup_node)
  where
    numbered_summaries :: [(ModSummary, Int)]
numbered_summaries = [ModSummary] -> [Int] -> [(ModSummary, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModSummary]
summaries [Int
1..]

    lookup_node :: ModuleNameWithIsBoot -> Maybe SummaryNode
    lookup_node :: NodeKey -> Maybe (Node Int ModSummary)
lookup_node NodeKey
mnwib = NodeKey
-> Map NodeKey (Node Int ModSummary) -> Maybe (Node Int ModSummary)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
mnwib Map NodeKey (Node Int ModSummary)
node_map

    lookup_key :: ModuleNameWithIsBoot -> Maybe Int
    lookup_key :: NodeKey -> Maybe Int
lookup_key = (Node Int ModSummary -> Int)
-> Maybe (Node Int ModSummary) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node Int ModSummary -> Int
summaryNodeKey (Maybe (Node Int ModSummary) -> Maybe Int)
-> (NodeKey -> Maybe (Node Int ModSummary)) -> NodeKey -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe (Node Int ModSummary)
lookup_node

    node_map :: NodeMap SummaryNode
    node_map :: Map NodeKey (Node Int ModSummary)
node_map = [(NodeKey, Node Int ModSummary)]
-> Map NodeKey (Node Int ModSummary)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModSummary -> NodeKey
mkHomeBuildModule ModSummary
s, Node Int ModSummary
node)
                            | Node Int ModSummary
node <- [Node Int ModSummary]
nodes
                            , let s :: ModSummary
s = Node Int ModSummary -> ModSummary
summaryNodeSummary Node Int ModSummary
node
                            ]

    -- We use integers as the keys for the SCC algorithm
    nodes :: [SummaryNode]
    nodes :: [Node Int ModSummary]
nodes = [ ModSummary -> Int -> [Int] -> Node Int ModSummary
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ModSummary
s Int
key ([Int] -> Node Int ModSummary) -> [Int] -> Node Int ModSummary
forall a b. (a -> b) -> a -> b
$ [NodeKey] -> [Int]
out_edge_keys ([NodeKey] -> [Int]) -> [NodeKey] -> [Int]
forall a b. (a -> b) -> a -> b
$ Bool -> ModSummary -> [NodeKey]
unfilteredEdges Bool
drop_hs_boot_nodes ModSummary
s
            | (ModSummary
s, Int
key) <- [(ModSummary, Int)]
numbered_summaries
             -- Drop the hi-boot ones if told to do so
            , Bool -> Bool
not (ModSummary -> IsBootInterface
isBootSummary ModSummary
s IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot Bool -> Bool -> Bool
&& Bool
drop_hs_boot_nodes)
            ]

    out_edge_keys :: [ModuleNameWithIsBoot] -> [Int]
    out_edge_keys :: [NodeKey] -> [Int]
out_edge_keys = (NodeKey -> Maybe Int) -> [NodeKey] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe Int
lookup_key
        -- If we want keep_hi_boot_nodes, then we do lookup_key with
        -- IsBoot; else False

-- The nodes of the graph are keyed by (mod, is boot?) pairs
-- NB: hsig files show up as *normal* nodes (not boot!), since they don't
-- participate in cycles (for now)
type NodeKey   = ModuleNameWithIsBoot
type NodeMap a = Map.Map NodeKey a

msKey :: ModSummary -> NodeKey
msKey :: ModSummary -> NodeKey
msKey (ModSummary { ms_mod :: ModSummary -> Module
ms_mod = Module
mod, ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
boot })
    = GWIB :: forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB
        { gwib_mod :: ModuleName
gwib_mod = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod
        , gwib_isBoot :: IsBootInterface
gwib_isBoot = HscSource -> IsBootInterface
hscSourceToIsBoot HscSource
boot
        }

mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap [ModSummary]
summaries = [(NodeKey, ModSummary)] -> NodeMap ModSummary
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModSummary -> NodeKey
msKey ModSummary
s, ModSummary
s) | ModSummary
s <- [ModSummary]
summaries]

nodeMapElts :: NodeMap a -> [a]
nodeMapElts :: forall a. NodeMap a -> [a]
nodeMapElts = Map NodeKey a -> [a]
forall k a. Map k a -> [a]
Map.elems

-- | 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
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedImports DynFlags
dflags)
    (ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag ((SCC ModSummary -> [ErrMsg]) -> [SCC ModSummary] -> [ErrMsg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags -> [ModSummary] -> [ErrMsg]
check DynFlags
dflags ([ModSummary] -> [ErrMsg])
-> (SCC ModSummary -> [ModSummary]) -> SCC ModSummary -> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs)))
  where check :: DynFlags -> [ModSummary] -> [ErrMsg]
check DynFlags
dflags [ModSummary]
ms =
           let mods_in_this_cycle :: [ModuleName]
mods_in_this_cycle = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
ms in
           [ DynFlags -> GenLocated SrcSpan ModuleName -> ErrMsg
warn DynFlags
dflags GenLocated SrcSpan ModuleName
i | ModSummary
m <- [ModSummary]
ms, GenLocated SrcSpan ModuleName
i <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
m,
                             GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
i ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`  [ModuleName]
mods_in_this_cycle ]

        warn :: DynFlags -> Located ModuleName -> WarnMsg
        warn :: DynFlags -> GenLocated SrcSpan ModuleName -> ErrMsg
warn DynFlags
dflags (L SrcSpan
loc ModuleName
mod) =
           DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
loc
                (FilePath -> SDoc
text FilePath
"Warning: {-# SOURCE #-} unnecessary in import of "
                 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod))


-----------------------------------------------------------------------------
--
-- | 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 [Either ErrorMessages ModSummary]
                -- The elts of [ModSummary] all have distinct
                -- (Modules, IsBoot) identifiers, unless the Bool is true
                -- in which case there can be repeats
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ModSummary]
downsweep HscEnv
hsc_env [ModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots
   = do
       [Either ErrorMessages ModSummary]
rootSummaries <- (Target -> IO (Either ErrorMessages ModSummary))
-> [Target] -> IO [Either ErrorMessages ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Target -> IO (Either ErrorMessages ModSummary)
getRootSummary [Target]
roots
       let ([ErrorMessages]
errs, [ModSummary]
rootSummariesOk) = [Either ErrorMessages ModSummary]
-> ([ErrorMessages], [ModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ModSummary]
rootSummaries -- #17549
           root_map :: NodeMap [Either ErrorMessages ModSummary]
root_map = [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap [ModSummary]
rootSummariesOk
       NodeMap [Either ErrorMessages ModSummary] -> IO ()
checkDuplicates NodeMap [Either ErrorMessages ModSummary]
root_map
       NodeMap [Either ErrorMessages ModSummary]
map0 <- [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop ((ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)])
-> [ModSummary] -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps [ModSummary]
rootSummariesOk) NodeMap [Either ErrorMessages ModSummary]
root_map
       -- 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
       NodeMap [Either ErrorMessages ModSummary]
map1 <- if DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing
         then HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH
           (DynFlags -> HscTarget
defaultObjectTarget DynFlags
dflags)
           NodeMap [Either ErrorMessages ModSummary]
map0
         else if DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted
           then HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuplesOrSums
             (DynFlags -> HscTarget
defaultObjectTarget DynFlags
dflags)
             NodeMap [Either ErrorMessages ModSummary]
map0
           else NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
map0
       if [ErrorMessages] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMessages]
errs
         then [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either ErrorMessages ModSummary]
 -> IO [Either ErrorMessages ModSummary])
-> [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ [[Either ErrorMessages ModSummary]]
-> [Either ErrorMessages ModSummary]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either ErrorMessages ModSummary]]
 -> [Either ErrorMessages ModSummary])
-> [[Either ErrorMessages ModSummary]]
-> [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ NodeMap [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall a. NodeMap a -> [a]
nodeMapElts NodeMap [Either ErrorMessages ModSummary]
map1
         else [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either ErrorMessages ModSummary]
 -> IO [Either ErrorMessages ModSummary])
-> [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ (ErrorMessages -> Either ErrorMessages ModSummary)
-> [ErrorMessages] -> [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map ErrorMessages -> Either ErrorMessages ModSummary
forall a b. a -> Either a b
Left [ErrorMessages]
errs
     where
        calcDeps :: ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps = ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps

        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        roots :: [Target]
roots = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env

        old_summary_map :: NodeMap ModSummary
        old_summary_map :: NodeMap ModSummary
old_summary_map = [ModSummary] -> NodeMap ModSummary
mkNodeMap [ModSummary]
old_summaries

        getRootSummary :: Target -> IO (Either ErrorMessages ModSummary)
        getRootSummary :: Target -> IO (Either ErrorMessages ModSummary)
getRootSummary (Target (TargetFile FilePath
file Maybe Phase
mb_phase) Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf)
           = do Bool
exists <- IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
file
                if Bool
exists Bool -> Bool -> Bool
|| Maybe (InputFileBuffer, UTCTime) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (InputFileBuffer, UTCTime)
maybe_buf
                    then HscEnv
-> [ModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ModSummary)
summariseFile HscEnv
hsc_env [ModSummary]
old_summaries FilePath
file Maybe Phase
mb_phase
                                       Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf
                    else Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages ModSummary
 -> IO (Either ErrorMessages ModSummary))
-> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages ModSummary
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages ModSummary)
-> ErrorMessages -> Either ErrorMessages ModSummary
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrorMessages
forall a. a -> Bag a
unitBag (ErrMsg -> ErrorMessages) -> ErrMsg -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
noSrcSpan (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                           FilePath -> SDoc
text FilePath
"can't find file:" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
file
        getRootSummary (Target (TargetModule ModuleName
modl) Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf)
           = do Maybe (Either ErrorMessages ModSummary)
maybe_summary <- HscEnv
-> NodeMap ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule HscEnv
hsc_env NodeMap ModSummary
old_summary_map IsBootInterface
NotBoot
                                           (SrcSpan -> ModuleName -> GenLocated SrcSpan ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) Bool
obj_allowed
                                           Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
                case Maybe (Either ErrorMessages ModSummary)
maybe_summary of
                   Maybe (Either ErrorMessages ModSummary)
Nothing -> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages ModSummary
 -> IO (Either ErrorMessages ModSummary))
-> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages ModSummary
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages ModSummary)
-> ErrorMessages -> Either ErrorMessages ModSummary
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> ErrorMessages
moduleNotFoundErr DynFlags
dflags ModuleName
modl
                   Just Either ErrorMessages ModSummary
s  -> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorMessages ModSummary
s

        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 :: NodeMap [Either ErrorMessages ModSummary] -> IO ()
        checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO ()
checkDuplicates NodeMap [Either ErrorMessages ModSummary]
root_map
           | Bool
allow_dup_roots = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | [[ModSummary]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModSummary]]
dup_roots  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | Bool
otherwise       = IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [ModSummary] -> IO ()
multiRootsErr DynFlags
dflags ([[ModSummary]] -> [ModSummary]
forall a. [a] -> a
head [[ModSummary]]
dup_roots)
           where
             dup_roots :: [[ModSummary]]        -- Each at least of length 2
             dup_roots :: [[ModSummary]]
dup_roots = ([ModSummary] -> Bool) -> [[ModSummary]] -> [[ModSummary]]
forall a. (a -> Bool) -> [a] -> [a]
filterOut [ModSummary] -> Bool
forall a. [a] -> Bool
isSingleton ([[ModSummary]] -> [[ModSummary]])
-> [[ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> a -> b
$ ([Either ErrorMessages ModSummary] -> [ModSummary])
-> [[Either ErrorMessages ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> [a] -> [b]
map [Either ErrorMessages ModSummary] -> [ModSummary]
forall a b. [Either a b] -> [b]
rights ([[Either ErrorMessages ModSummary]] -> [[ModSummary]])
-> [[Either ErrorMessages ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> a -> b
$ NodeMap [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall a. NodeMap a -> [a]
nodeMapElts NodeMap [Either ErrorMessages ModSummary]
root_map

        loop :: [GenWithIsBoot (Located ModuleName)]
                        -- Work list: process these modules
             -> NodeMap [Either ErrorMessages ModSummary]
                        -- Visited set; the range is a list because
                        -- the roots can have the same module names
                        -- if allow_dup_roots is True
             -> IO (NodeMap [Either ErrorMessages ModSummary])
                        -- The result is the completed NodeMap
        loop :: [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [] NodeMap [Either ErrorMessages ModSummary]
done = NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
done
        loop (GenWithIsBoot (GenLocated SrcSpan ModuleName)
s : [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss) NodeMap [Either ErrorMessages ModSummary]
done
          | Just [Either ErrorMessages ModSummary]
summs <- NodeKey
-> NodeMap [Either ErrorMessages ModSummary]
-> Maybe [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
key NodeMap [Either ErrorMessages ModSummary]
done
          = if [Either ErrorMessages ModSummary] -> Bool
forall a. [a] -> Bool
isSingleton [Either ErrorMessages ModSummary]
summs then
                [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss NodeMap [Either ErrorMessages ModSummary]
done
            else
                do { DynFlags -> [ModSummary] -> IO ()
multiRootsErr DynFlags
dflags ([Either ErrorMessages ModSummary] -> [ModSummary]
forall a b. [Either a b] -> [b]
rights [Either ErrorMessages ModSummary]
summs); NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
forall k a. Map k a
Map.empty }
          | Bool
otherwise
          = do Maybe (Either ErrorMessages ModSummary)
mb_s <- HscEnv
-> NodeMap ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule HscEnv
hsc_env NodeMap ModSummary
old_summary_map
                                       IsBootInterface
is_boot GenLocated SrcSpan ModuleName
wanted_mod Bool
True
                                       Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing [ModuleName]
excl_mods
               case Maybe (Either ErrorMessages ModSummary)
mb_s of
                   Maybe (Either ErrorMessages ModSummary)
Nothing -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss NodeMap [Either ErrorMessages ModSummary]
done
                   Just (Left ErrorMessages
e) -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss (NodeKey
-> [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NodeKey
key [ErrorMessages -> Either ErrorMessages ModSummary
forall a b. a -> Either a b
Left ErrorMessages
e] NodeMap [Either ErrorMessages ModSummary]
done)
                   Just (Right ModSummary
s)-> do
                     NodeMap [Either ErrorMessages ModSummary]
new_map <-
                       [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop (ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps ModSummary
s) (NodeKey
-> [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NodeKey
key [ModSummary -> Either ErrorMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s] NodeMap [Either ErrorMessages ModSummary]
done)
                     [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
ss NodeMap [Either ErrorMessages ModSummary]
new_map
          where
            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)
s
            wanted_mod :: GenLocated SrcSpan ModuleName
wanted_mod = SrcSpan -> ModuleName -> GenLocated SrcSpan ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ModuleName
mod
            key :: NodeKey
key = GWIB :: forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB
                    { gwib_mod :: ModuleName
gwib_mod = GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
wanted_mod
                    , gwib_isBoot :: IsBootInterfac