{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# 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(..),
        instantiationNodes,

        downsweep,

        topSortModuleGraph,

        ms_home_srcimps, ms_home_imps,

        summariseModule,
        hscSourceToIsBoot,
        findExtraSigImports,
        implicitRequirementsShallow,

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

        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert
    ) where

#include "HsVersions.h"

import GHC.Prelude

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

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

import GHC.Runtime.Context

import GHC.Driver.Config
import GHC.Driver.Phases
import GHC.Driver.Pipeline
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Main

import GHC.Parser.Header
import GHC.Parser.Errors.Ppr

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

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

import GHC.Utils.Exception ( tryIO )
import GHC.Utils.Monad     ( allM )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.TmpFs

import GHC.Types.Basic
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import GHC.Types.Name
import GHC.Types.Name.Env

import GHC.Unit
import GHC.Unit.State
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo

import 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 (nub, sortBy, partition)
import qualified Data.List as List
import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
import Data.Bifunctor (first)
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) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots
    if forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
      else 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 <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
    if forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then do
        let unused_home_mod_err :: [MsgEnvelope DecoratedSDoc]
unused_home_mod_err = HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph
            unused_pkg_err :: [MsgEnvelope DecoratedSDoc]
unused_pkg_err = HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages HscEnv
hsc_env ModuleGraph
mod_graph
            warns :: [MsgEnvelope DecoratedSDoc]
warns = [MsgEnvelope DecoratedSDoc]
unused_home_mod_err forall a. [a] -> [a] -> [a]
++ [MsgEnvelope DecoratedSDoc]
unused_pkg_err
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MsgEnvelope DecoratedSDoc]
warns) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings (forall a. [a] -> Bag a
listToBag [MsgEnvelope DecoratedSDoc]
warns)
        forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
        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.
        forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG }
        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 <- 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
         logger :: Logger
logger  = HscEnv -> Logger
hsc_logger HscEnv
hsc_env

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

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

    [Either ErrorMessages ExtendedModSummary]
mod_summariesE <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> [ExtendedModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ExtendedModSummary]
downsweep
      HscEnv
hsc_env (ModuleGraph -> [ExtendedModSummary]
mgExtendedModSummaries ModuleGraph
old_graph)
      [ModuleName]
excluded_mods Bool
allow_dup_roots
    let
      ([ErrorMessages]
errs, [ExtendedModSummary]
mod_summaries) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ExtendedModSummary]
mod_summariesE
      mod_graph :: ModuleGraph
mod_graph = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph' forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtendedModSummary -> ModuleGraphNode
ModuleNode [ExtendedModSummary]
mod_summaries forall a. [a] -> [a] -> [a]
++ UnitState -> [ModuleGraphNode]
instantiationNodes (HscEnv -> UnitState
hsc_units HscEnv
hsc_env)
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Bag a] -> Bag a
unionManyBags [ErrorMessages]
errs, ModuleGraph
mod_graph)

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

-- 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 -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph =
    if (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingHomeModules DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing))
    then [MsgEnvelope DecoratedSDoc
warn]
    else []
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    targets :: [TargetId]
targets = 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 = 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)
      = forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod) 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 forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||

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

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

    missing :: [ModuleName]
missing = forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) forall a b. (a -> b) -> a -> b
$
      forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
is_known_module) (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 (forall a b. (a -> b) -> [a] -> [b]
map 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
    warn :: MsgEnvelope DecoratedSDoc
warn = forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning
      (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingHomeModules)
      (SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope 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 backend (see 'DynFlags.backend' field) compiling
-- and loading may result in files being created on disk.
--
-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
-- successful or not.
--
-- If errors are encountered during dependency analysis, the module `depanalE`
-- returns together with the errors an empty ModuleGraph.
-- After processing this empty ModuleGraph, the errors of depanalE are thrown.
-- All other errors are reported using the 'defaultWarnErrLogger'.
--
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load :: forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
load LoadHowMuch
how_much = do
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalE [] Bool
False                        -- #17459
    SuccessFlag
success <- forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much (forall a. a -> Maybe a
Just Messager
batchMsg) ModuleGraph
mod_graph
    if forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
      else 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 -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]
warnUnusedPackages HscEnv
hsc_env ModuleGraph
mod_graph =
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        state :: UnitState
state  = HscEnv -> UnitState
hsc_units HscEnv
hsc_env

    -- Only need non-source imports here because SOURCE imports are always HPT
        loadedPackages :: [UnitInfo]
loadedPackages = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Maybe FastString
fs, GenLocated SrcSpan ModuleName
mn) -> UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]
lookupModulePackage UnitState
state (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
mn) Maybe FastString
fs)
            forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageFlag -> Maybe PackageArg
packageArg (DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags)

        unusedArgs :: [PackageArg]
unusedArgs
          = forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageArg
arg -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ 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 :: MsgEnvelope DecoratedSDoc
warn = forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning
          (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedPackages)
          (SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope 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 (forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
withDash forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageArg -> SDoc
pprUnusedArg) [PackageArg]
unusedArgs)) ]

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

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

        pprUnusedArg :: PackageArg -> SDoc
pprUnusedArg (PackageArg FilePath
str) = FilePath -> SDoc
text FilePath
str
        pprUnusedArg (UnitIdArg Unit
uid) = forall a. Outputable a => a -> SDoc
ppr Unit
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 forall a. Eq a => a -> a -> Bool
== forall u. GenUnitInfo u -> FilePath
unitPackageIdString UnitInfo
p
                Bool -> Bool -> Bool
|| FilePath
str forall a. Eq a => a -> a -> Bool
== 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 Unit
uid) UnitInfo
p = Unit
uid forall a. Eq a => a -> a -> Bool
== UnitState -> UnitInfo -> Unit
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 -> Unit
realUnit UnitState
state
          = UnitState -> Unit -> Unit
unwireUnit UnitState
state
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall uid. Definite uid -> GenUnit uid
RealUnit
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. unit -> Definite unit
Definite
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
    forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
    forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
    HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

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

    -- The "bad" boot modules are the ones for which we have
    -- B.hs-boot in the module graph, but no B.hs
    -- The downsweep should have ensured this does not happen
    -- (see msDeps)
    let all_home_mods :: UniqSet ModuleName
all_home_mods =
          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 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
checkMod ModuleName
m
        checkHowMuch (LoadDependenciesOf ModuleName
m) = ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m
        checkHowMuch LoadHowMuch
_ = forall a. a -> a
id

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

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

    -- mg2_with_srcimps drops the hi-boot nodes, returning a
    -- graph with cycles.  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 = [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules forall a b. (a -> b) -> a -> b
$
          Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph forall a. Maybe a
Nothing

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

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

        pruned_hpt :: HomePackageTable
pruned_hpt = HomePackageTable
hpt1

    HomePackageTable
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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.
    forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
pruned_hpt }

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Stable obj:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_obj SDoc -> SDoc -> SDoc
$$
                            FilePath -> SDoc
text FilePath
"Stable BCO:" SDoc -> SDoc -> 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 <- forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_obj forall a. [a] -> [a] -> [a]
++
                                  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] ]
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp 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, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode]
        stable_mg :: [SCC ExtendedModSummary]
        full_mg :: [SCC ModuleGraphNode]
full_mg    = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mod_graph forall a. Maybe a
Nothing

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

        partial_mg0 :: [SCC ModuleGraphNode]
partial_mg0 = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
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 ModuleGraphNode]
partial_mg
            | LoadDependenciesOf ModuleName
_mod <- LoadHowMuch
how_much
            = ASSERT( case last partial_mg0 of
                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )
              forall a. [a] -> [a]
List.init [SCC ModuleGraphNode]
partial_mg0
            | Bool
otherwise
            = [SCC ModuleGraphNode]
partial_mg0

        stable_mg :: [SCC ExtendedModSummary]
stable_mg =
            [ forall vertex. vertex -> SCC vertex
AcyclicSCC ExtendedModSummary
ems
            | AcyclicSCC (ModuleNode ems :: ExtendedModSummary
ems@(ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)) <- [SCC ModuleGraphNode]
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 forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj Bool -> Bool -> Bool
||
          ModSummary -> ModuleName
ms_mod_name ModSummary
ms 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 ModuleGraphNode]
unstable_mg = forall a. (a -> Bool) -> [a] -> [a]
filter SCC ModuleGraphNode -> Bool
not_stable [SCC ModuleGraphNode]
partial_mg
          where not_stable :: SCC ModuleGraphNode -> Bool
not_stable (CyclicSCC [ModuleGraphNode]
_) = Bool
True
                not_stable (AcyclicSCC (InstantiationNode InstantiatedUnit
_)) = Bool
True
                not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)))
                   = Bool -> Bool
not 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 ModuleGraphNode]
mg = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExtendedModSummary -> ModuleGraphNode
ModuleNode) [SCC ExtendedModSummary]
stable_mg forall a. [a] -> [a] -> [a]
++ [SCC ModuleGraphNode]
unstable_mg

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

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

    forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }
    (SuccessFlag
upsweep_ok, [ModuleGraphNode]
modsUpswept) <- forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics forall a b. (a -> b) -> a -> b
$
      Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep_fn Maybe Messager
mHscMessage HomePackageTable
pruned_hpt StableModules
stable_mods [SCC ModuleGraphNode]
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 nodesDone :: [ModuleGraphNode]
nodesDone = forall a. [a] -> [a]
reverse [ModuleGraphNode]
modsUpswept
        ([InstantiatedUnit]
_, [ExtendedModSummary]
modsDone) = [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
nodesDone

    -- 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 forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 (FilePath -> SDoc
text FilePath
"Upsweep completely successful.")

          -- Clean up after ourselves
          HscEnv
hsc_env1 <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles Logger
logger (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env1) 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 = HscEnv -> Module
mainModIs HscEnv
hsc_env
            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 forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib

          -- link everything together
          HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          SuccessFlag
linkresult <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> HomePackageTable
-> IO SuccessFlag
link (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
                                      Logger
logger
                                      (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
                                      (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env)
                                      DynFlags
dflags
                                      (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
                                      Bool
do_linking
                                      (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1)

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

          let modsDone_names :: [Module]
modsDone_names
                 = forall a b. (a -> b) -> [a] -> [b]
map (ModSummary -> Module
ms_mod forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtendedModSummary -> ModSummary
emsModSummary) [ExtendedModSummary]
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) =
                forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
mods_to_zap_names)forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModSummary -> Module
ms_mod) forall a b. (a -> b) -> a -> b
$
                ExtendedModSummary -> ModSummary
emsModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExtendedModSummary]
modsDone
          HscEnv
hsc_env1 <- 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [FilePath
ms_hspp_file 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Linkable -> [FilePath]
linkableObjs forall a b. (a -> b) -> a -> b
$
                        HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt4 (forall unit. GenModule unit -> ModuleName
moduleName Module
ms_mod)
                        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HomeModInfo -> Maybe Linkable
hm_linkable
                ]
          TmpFs
tmpfs <- HscEnv -> TmpFs
hsc_tmpfs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
changeTempFilesLifetime TmpFs
tmpfs TempFileLifetime
TFL_CurrentModule [FilePath]
unneeded_temps
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs DynFlags
dflags

          let hpt5 :: HomePackageTable
hpt5 = [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs (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 (forall a. Maybe a -> Bool
isJustforall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> Maybe Linkable
hm_linkable)
                        ((HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
filterHpt ((forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (phase :: ModIfacePhase). ModIface_ phase -> HscSource
mi_hsc_srcforall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> ModIface
hm_iface)
                                HomePackageTable
hpt5)
          ASSERT( just_linkables ) do

          -- Link everything together
          hsc_env <- getSession
          linkresult <- liftIO $ link (ghcLink dflags)
                                      logger
                                      (hsc_tmpfs hsc_env)
                                      (hsc_hooks hsc_env)
                                      dflags
                                      (hsc_unit_env hsc_env)
                                      False
                                      hpt5

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

partitionNodes
  :: [ModuleGraphNode]
  -> ( [InstantiatedUnit]
     , [ExtendedModSummary]
     )
partitionNodes :: [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
ns = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ModuleGraphNode]
ns forall a b. (a -> b) -> a -> b
$ \case
  InstantiationNode InstantiatedUnit
x -> forall a b. a -> Either a b
Left InstantiatedUnit
x
  ModuleNode ExtendedModSummary
x -> forall a b. b -> Either a b
Right ExtendedModSummary
x

-- | 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 <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
       let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp HscEnv
hsc_env []
       forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardProg
       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 forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardIC
       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 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 and
-- the loaded plugins.  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
                                , ic_plugins :: [LoadedPlugin]
ic_plugins   = [LoadedPlugin]
old_plugins
                                } }
  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
  !old_plugins :: [LoadedPlugin]
old_plugins = InteractiveContext -> [LoadedPlugin]
ic_plugins InteractiveContext
old_ic
  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
    | HomeUnit -> Name -> Bool
nameIsFromExternalPackage HomeUnit
home_unit Name
old_name = Name
old_name
    | Bool
otherwise = InteractiveContext -> Name
ic_name InteractiveContext
empty_ic
    where
    home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
    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 = forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession 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 (HscEnv -> Module
mainModIs HscEnv
env)
            ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
        name :: Maybe FilePath
name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
dropExtension Maybe FilePath
mainModuleSrcPath

        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' forall a. Eq a => a -> a -> Bool
== FilePath
mainModuleSrcPath'
            then forall a. GhcException -> a
throwGhcException forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
UsageError forall a b. (a -> b) -> a -> b
$
                 FilePath
"default output name would overwrite the input file; " forall a. [a] -> [a] -> [a]
++
                 FilePath
"must specify -o explicitly"
            else forall a. a -> Maybe a
Just FilePath
name'
    in
    case DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags of
        Just FilePath
_ -> HscEnv
env
        Maybe FilePath
Nothing -> HscEnv
env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags { outputFile_ :: Maybe FilePath
outputFile_ = Maybe FilePath
name_exe } }

-- -----------------------------------------------------------------------------
--
-- | 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
   = 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 = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> Module
ms_mod [ModSummary]
vs)
             mods_in_this_cycle :: Set Module
mods_in_this_cycle =
                    forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (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.
       , forall a. Set a -> Int
Set.size Set Module
mods_in_this_cycle forall a. Ord a => a -> a -> Bool
< forall a. Set a -> Int
Set.size Set Module
names_in_this_cycle]


-- ---------------------------------------------------------------------------
--
-- | Unloading
unload :: Interp -> HscEnv -> [Linkable] -> IO ()
unload :: Interp -> HscEnv -> [Linkable] -> IO ()
unload Interp
interp 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 -> Interp -> HscEnv -> [Linkable] -> IO ()
Linker.unload Interp
interp HscEnv
hsc_env [Linkable]
stable_linkables
        GhcLink
_other -> 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 -> StableModules
checkStability HomePackageTable
hpt [SCC ModSummary]
sccs UniqSet ModuleName
all_home_mods =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' StableModules -> SCC ModSummary -> StableModules
checkSCC (forall a. UniqSet a
emptyUniqSet, forall a. UniqSet a
emptyUniqSet) [SCC ModSummary]
sccs
  where
   checkSCC :: StableModules -> SCC ModSummary -> StableModules
   checkSCC :: StableModules -> SCC ModSummary -> StableModules
checkSCC (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco) SCC ModSummary
scc0
     | Bool
stableObjects = (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, 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 = forall vertex. SCC vertex -> [vertex]
flattenSCC SCC ModSummary
scc0
        scc_mods :: [ModuleName]
scc_mods = 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 forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods Bool -> Bool -> Bool
&& ModuleName
m forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
scc_mods

        scc_allimps :: [ModuleName]
scc_allimps = forall a. Eq a => [a] -> [a]
nub (forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
home_module (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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj) [ModuleName]
scc_allimps
        stable_bco_imps :: [Bool]
stable_bco_imps = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco) [ModuleName]
scc_allimps

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

        stableBCOs :: Bool
stableBCOs =
           forall (t :: * -> *). Foldable t => t Bool -> Bool
and (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
&& 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 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 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 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, SDoc)])
                         !(MVar ())

-- | The graph of modules to compile and their corresponding result 'MVar' and
-- 'LogQueue'.
type CompilationGraph = [(ModuleGraphNode, 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 ModuleGraphNode] -> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph :: [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Maybe a
Nothing)
buildCompGraph (SCC ModuleGraphNode
scc:[SCC ModuleGraphNode]
sccs) = case SCC ModuleGraphNode
scc of
    AcyclicSCC ModuleGraphNode
ms -> do
        MVar SuccessFlag
mvar <- forall a. IO (MVar a)
newEmptyMVar
        LogQueue
log_queue <- do
            IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref <- forall a. a -> IO (IORef a)
newIORef []
            MVar ()
sem <- forall a. IO (MVar a)
newEmptyMVar
            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 [ModuleGraphNode]
cycle) <- [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [SCC ModuleGraphNode]
sccs
        forall (m :: * -> *) a. Monad m => a -> m a
return ((ModuleGraphNode
ms,MVar SuccessFlag
mvar,LogQueue
log_queue)forall a. a -> [a] -> [a]
:CompilationGraph
rest, Maybe [ModuleGraphNode]
cycle)
    CyclicSCC [ModuleGraphNode]
mss -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just [ModuleGraphNode]
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.
data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot
  deriving (BuildModule -> BuildModule -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildModule -> BuildModule -> Bool
$c/= :: BuildModule -> BuildModule -> Bool
== :: BuildModule -> BuildModule -> Bool
$c== :: BuildModule -> BuildModule -> Bool
Eq, Eq BuildModule
BuildModule -> BuildModule -> Bool
BuildModule -> BuildModule -> Ordering
BuildModule -> BuildModule -> BuildModule
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BuildModule -> BuildModule -> BuildModule
$cmin :: BuildModule -> BuildModule -> BuildModule
max :: BuildModule -> BuildModule -> BuildModule
$cmax :: BuildModule -> BuildModule -> BuildModule
>= :: BuildModule -> BuildModule -> Bool
$c>= :: BuildModule -> BuildModule -> Bool
> :: BuildModule -> BuildModule -> Bool
$c> :: BuildModule -> BuildModule -> Bool
<= :: BuildModule -> BuildModule -> Bool
$c<= :: BuildModule -> BuildModule -> Bool
< :: BuildModule -> BuildModule -> Bool
$c< :: BuildModule -> BuildModule -> Bool
compare :: BuildModule -> BuildModule -> Ordering
$ccompare :: BuildModule -> BuildModule -> Ordering
Ord)

-- | 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 :: ModuleGraphNode -> BuildModule
mkBuildModule :: ModuleGraphNode -> BuildModule
mkBuildModule = \case
  InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> BuildModule
BuildModule_Unit InstantiatedUnit
x
  ModuleNode ExtendedModSummary
ems -> ModuleWithIsBoot -> BuildModule
BuildModule_Module forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleWithIsBoot
mkBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)

mkHomeBuildModule :: ModuleGraphNode -> NodeKey
mkHomeBuildModule :: ModuleGraphNode -> NodeKey
mkHomeBuildModule = \case
  InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
x
  ModuleNode ExtendedModSummary
ems -> ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)

mkBuildModule0 :: ModSummary -> ModuleWithIsBoot
mkBuildModule0 :: ModSummary -> ModuleWithIsBoot
mkBuildModule0 ModSummary
ms = GWIB
  { gwib_mod :: Module
gwib_mod = ModSummary -> Module
ms_mod ModSummary
ms
  , gwib_isBoot :: IsBootInterface
gwib_isBoot = ModSummary -> IsBootInterface
isBootSummary ModSummary
ms
  }

mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot
mkHomeBuildModule0 :: ModSummary -> ModNodeKey
mkHomeBuildModule0 ModSummary
ms = GWIB
  { gwib_mod :: ModuleName
gwib_mod = forall unit. GenModule unit -> ModuleName
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
    -> [SCC ModuleGraphNode]
    -> m (SuccessFlag,
          [ModuleGraphNode])
parUpsweep :: forall (m :: * -> *).
GhcMonad m =>
Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
parUpsweep Int
n_jobs Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods [SCC ModuleGraphNode]
sccs = do
    HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let tmpfs :: TmpFs
tmpfs  = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env

    -- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef HomePackageTable
old_hpt

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


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

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

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

    m (SuccessFlag, [ModuleGraphNode])
-> m (SuccessFlag, [ModuleGraphNode])
finallySyncSession 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 [ModuleGraphNode]
cycle) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [SCC ModuleGraphNode]
-> IO (CompilationGraph, Maybe [ModuleGraphNode])
buildCompGraph [SCC ModuleGraphNode]
sccs
    let comp_graph_w_idx :: [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx = 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 :: [ModuleGraphNode]
graph = forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> a
fstOf3 (forall a. [a] -> [a]
reverse CompilationGraph
comp_graph)
        boot_modules :: ModuleSet
boot_modules = [Module] -> ModuleSet
mkModuleSet
          [ModSummary -> Module
ms_mod ModSummary
ms | ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_) <- [ModuleGraphNode]
graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
ms forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]
        comp_graph_loops :: [[BuildModule]]
comp_graph_loops = [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
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 :: [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [] ModuleSet
_ = []
            go (InstantiationNode InstantiatedUnit
_ : [ModuleGraphNode]
mss) ModuleSet
boot_modules
              = [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
mss ModuleSet
boot_modules
            go mg :: [ModuleGraphNode]
mg@(mnode :: ModuleGraphNode
mnode@(ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_)) : [ModuleGraphNode]
mss) ModuleSet
boot_modules
              | Just [ModuleGraphNode]
loop <- ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
mg (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleSet
boot_modules)
              = forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> BuildModule
mkBuildModule (ModuleGraphNode
mnode forall a. a -> [a] -> [a]
: [ModuleGraphNode]
loop) forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)
              | Bool
otherwise
              = [ModuleGraphNode] -> ModuleSet -> [[BuildModule]]
go [ModuleGraphNode]
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 =
            forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModuleGraphNode -> BuildModule
mkBuildModule ModuleGraphNode
ms, (MVar SuccessFlag
mvar, Int
idx))
                         | ((ModuleGraphNode
ms,MVar SuccessFlag
mvar,LogQueue
_),Int
idx) <- [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx ]


    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self FilePath
"main --make thread"

    -- Make the logger thread_safe: we only make the "log" action thread-safe in
    -- each worker by setting a LogAction hook, so we need to make the logger
    -- thread-safe for other actions (DumpAction, TraceAction).
    Logger
thread_safe_logger <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> IO Logger
makeThreadSafe Logger
logger

    -- For each module in the module graph, spawn a worker thread that will
    -- compile this module.
    let { spawnWorkers :: IO [ThreadId]
spawnWorkers = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((ModuleGraphNode, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx forall a b. (a -> b) -> a -> b
$ \((ModuleGraphNode
mod,!MVar SuccessFlag
mvar,!LogQueue
log_queue),!Int
mod_idx) ->
            ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ [ FilePath
"worker --make thread" ]
                    , case ModuleGraphNode
mod of
                        InstantiationNode InstantiatedUnit
iuid ->
                          [ FilePath
"for instantiation of unit"
                          , forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid
                          ]
                        ModuleNode ExtendedModSummary
ems ->
                          [ FilePath
"for module"
                          , forall a. Show a => a -> FilePath
show (ModuleName -> FilePath
moduleNameString (ModSummary -> ModuleName
ms_mod_name (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems)))
                          ]
                    , [FilePath
"number"
                      , 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.
                let lcl_logger :: Logger
lcl_logger = (LogAction -> LogAction) -> Logger -> Logger
pushLogHook (forall a b. a -> b -> a
const (LogQueue -> LogAction
parLogAction LogQueue
log_queue)) Logger
thread_safe_logger

                -- Use a local TmpFs 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.
                TmpFs
lcl_tmpfs <- TmpFs -> IO TmpFs
forkTmpFsFrom TmpFs
tmpfs

                -- Unmask asynchronous exceptions and perform the thread-local
                -- work to compile the module (see parUpsweep_one).
                Either SomeException SuccessFlag
m_res <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors DynFlags
dflags forall a b. (a -> b) -> a -> b
$
                  case ModuleGraphNode
mod of
                    InstantiationNode InstantiatedUnit
iuid -> do
                      HscEnv
hsc_env <- forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe Messager -> Int -> Int -> InstantiatedUnit -> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_idx (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs) InstantiatedUnit
iuid
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
Succeeded
                    ModuleNode ExtendedModSummary
ems ->
                      ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> Logger
-> TmpFs
-> DynFlags
-> HomeUnit
-> Maybe Messager
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems) Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops
                                     Logger
lcl_logger TmpFs
lcl_tmpfs DynFlags
dflags (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env)
                                     Maybe Messager
mHscMessage
                                     QSem
par_sem MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var
                                     StableModules
stable_mods Int
mod_idx (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs)

                SuccessFlag
res <- case Either SomeException SuccessFlag
m_res of
                    Right SuccessFlag
flag -> 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.
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just AsyncException
ThreadKilled)
                             (Logger -> DynFlags -> SDoc -> IO ()
errorMsg Logger
lcl_logger DynFlags
dflags (FilePath -> SDoc
text (forall a. Show a => a -> FilePath
show SomeException
exc)))
                        forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed

                -- Populate the result MVar.
                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 forall a. Maybe a
Nothing

                -- Add the remaining files that weren't cleaned up to the
                -- global TmpFs, for cleanup later.
                TmpFs -> TmpFs -> IO ()
mergeTmpFsInto TmpFs
lcl_tmpfs TmpFs
tmpfs

        -- Kill all the workers, masking interrupts (since killThread is
        -- interruptible). XXX: This is not ideal.
        ; killWorkers :: [ThreadId] -> IO ()
killWorkers = forall (m :: * -> *) a. MonadMask m => m a -> m a
MC.uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 ModuleGraphNode]
results <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 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.
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM CompilationGraph
comp_graph forall a b. (a -> b) -> a -> b
$ \(ModuleGraphNode
mod,MVar SuccessFlag
mvar,LogQueue
log_queue) -> do
            Logger -> DynFlags -> LogQueue -> IO ()
printLogs Logger
logger DynFlags
dflags LogQueue
log_queue
            SuccessFlag
result <- forall a. MVar a -> IO a
readMVar MVar SuccessFlag
mvar
            if SuccessFlag -> Bool
succeeded SuccessFlag
result then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ModuleGraphNode
mod) else forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: [ModuleGraphNode]
ok_results = forall a. [a] -> [a]
reverse (forall a. [Maybe a] -> [a]
catMaybes [Maybe ModuleGraphNode]
results)

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

  where
    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> 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
        forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref forall a b. (a -> b) -> a -> b
$ \[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs -> (Maybe (WarnReason, Severity, SrcSpan, SDoc)
msgforall a. a -> [a] -> [a]
:[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs,())
        Bool
_ <- forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
sem ()
        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 =
        LogQueue -> Maybe (WarnReason, Severity, SrcSpan, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue (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 :: Logger -> DynFlags -> LogQueue -> IO ()
    printLogs :: Logger -> DynFlags -> LogQueue -> IO ()
printLogs !Logger
logger !DynFlags
dflags (LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref MVar ()
sem) = IO ()
read_msgs
      where read_msgs :: IO ()
read_msgs = do
                forall a. MVar a -> IO a
takeMVar MVar ()
sem
                [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
msgs <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]
ref forall a b. (a -> b) -> a -> b
$ \[Maybe (WarnReason, Severity, SrcSpan, SDoc)]
xs -> ([], 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
                    Logger -> LogAction
putLogMsg Logger
logger 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 -> 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.
    -> Logger
    -- ^ The thread-local Logger
    -> TmpFs
    -- ^ The thread-local TmpFs
    -> DynFlags
    -- ^ The thread-local DynFlags
    -> HomeUnit
    -- ^ The home-unit
    -> Maybe Messager
    -- ^ The messager
    -> 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]]
-> Logger
-> TmpFs
-> DynFlags
-> HomeUnit
-> Maybe Messager
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one ModSummary
mod Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops Logger
lcl_logger TmpFs
lcl_tmpfs DynFlags
lcl_dflags HomeUnit
home_unit Maybe Messager
mHscMessage QSem
par_sem
               MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var StableModules
stable_mods Int
mod_index Int
num_mods = do

    let this_build_mod :: ModuleWithIsBoot
this_build_mod = ModSummary -> ModuleWithIsBoot
mkBuildModule0 ModSummary
mod

    let home_imps :: [ModuleName]
home_imps     = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
mod
    let home_src_imps :: [ModuleName]
home_src_imps = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc 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 = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
            forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> IsBootInterface -> BuildModule
f [ModuleName]
home_imps     (forall a. a -> [a]
repeat IsBootInterface
NotBoot) forall a. [a] -> [a] -> [a]
++
            forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> IsBootInterface -> BuildModule
f [ModuleName]
home_src_imps (forall a. a -> [a]
repeat IsBootInterface
IsBoot)
          where f :: ModuleName -> IsBootInterface -> BuildModule
f ModuleName
mn IsBootInterface
isBoot = ModuleWithIsBoot -> BuildModule
BuildModule_Module forall a b. (a -> b) -> a -> b
$ GWIB
                  { gwib_mod :: Module
gwib_mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit 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 [ModuleWithIsBoot]
        finish_loop :: Maybe [ModuleWithIsBoot]
finish_loop = forall a. [a] -> Maybe a
listToMaybe
          [ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. [a] -> [a]
tail [BuildModule]
loop) forall a b. (a -> b) -> a -> b
$ \case
              BuildModule_Unit InstantiatedUnit
_ -> forall a. Maybe a
Nothing
              BuildModule_Module ModuleWithIsBoot
ms -> forall a. a -> Maybe a
Just ModuleWithIsBoot
ms
          | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
          , forall a. [a] -> a
head [BuildModule]
loop forall a. Eq a => a -> a -> Bool
== ModuleWithIsBoot -> BuildModule
BuildModule_Module ModuleWithIsBoot
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.Set BuildModule
        int_loop_deps :: Set BuildModule
int_loop_deps = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$
            case Maybe [ModuleWithIsBoot]
finish_loop of
                Maybe [ModuleWithIsBoot]
Nothing   -> []
                Just [ModuleWithIsBoot]
loop -> ModuleWithIsBoot -> BuildModule
BuildModule_Module forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= ModuleWithIsBoot
this_build_mod) [ModuleWithIsBoot]
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.Set BuildModule
        ext_loop_deps :: Set BuildModule
ext_loop_deps = forall a. Ord a => [a] -> Set a
Set.fromList
            [ forall a. [a] -> a
head [BuildModule]
loop | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
                        , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildModule
textual_deps) [BuildModule]
loop
                        , ModuleWithIsBoot -> BuildModule
BuildModule_Module ModuleWithIsBoot
this_build_mod forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BuildModule]
loop ]


    let all_deps :: Set BuildModule
all_deps = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 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 <- forall a. Set a -> [a]
Set.toList Set BuildModule
all_deps
                       , Just (MVar SuccessFlag, Int)
home_dep <- [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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing 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 <- forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SuccessFlag -> Bool
succeeded forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 <- forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
        HomePackageTable
old_hpt <- forall a. IORef a -> IO a
readIORef IORef HomePackageTable
old_hpt_var

        let logg :: SourceError -> IO ()
logg SourceError
err = forall a.
RenderableDiagnostic a =>
Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
printBagOfErrors Logger
lcl_logger DynFlags
lcl_dflags (SourceError -> ErrorMessages
srcErrorMessages SourceError
err)

        -- Limit the number of parallel compiles.
        let withSem :: QSem -> IO b -> IO b
withSem QSem
sem = 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 <- forall {b}. QSem -> IO b -> IO b
withSem QSem
par_sem forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
MonadCatch m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\SourceError
err -> do SourceError -> IO ()
logg SourceError
err; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
                -- Have the HscEnv point to our local logger and tmpfs.
                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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef 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 =
                                    forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
mod, IORef (NameEnv TyThing)
type_env_var) }
                HscEnv
lcl_hsc_env'' <- case Maybe [ModuleWithIsBoot]
finish_loop of
                    Maybe [ModuleWithIsBoot]
Nothing   -> 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 [ModuleWithIsBoot]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
lcl_hsc_env' forall a b. (a -> b) -> a -> b
$
                                 forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName (forall mod. GenWithIsBoot mod -> mod
gwib_mod ModuleWithIsBoot
this_build_mod)) forall a b. (a -> b) -> a -> b
$
                                 forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. GenWithIsBoot mod -> mod
gwib_mod) [ModuleWithIsBoot]
loop

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

        case Maybe HomeModInfo
mb_mod_info of
            Maybe HomeModInfo
Nothing -> 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.
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ModSummary -> IsBootInterface
isBootSummary ModSummary
mod forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) forall a b. (a -> b) -> a -> b
$
                    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef HomePackageTable
old_hpt_var 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' <- forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar HscEnv
hsc_env_var 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 [ModuleWithIsBoot]
finish_loop of
                        Maybe [ModuleWithIsBoot]
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env'
                        Just [ModuleWithIsBoot]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
hsc_env' forall a b. (a -> b) -> a -> b
$
                                     forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. GenWithIsBoot mod -> mod
gwib_mod) [ModuleWithIsBoot]
loop
                    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.
                Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles (HscEnv -> Logger
hsc_logger HscEnv
lcl_hsc_env')
                                            (HscEnv -> TmpFs
hsc_tmpfs  HscEnv
lcl_hsc_env')
                                            (HscEnv -> DynFlags
hsc_dflags HscEnv
lcl_hsc_env')
                forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded

  where
    localize_hsc_env :: HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env
        = HscEnv
hsc_env { hsc_logger :: Logger
hsc_logger = Logger
lcl_logger
                  , hsc_tmpfs :: TmpFs
hsc_tmpfs  = TmpFs
lcl_tmpfs
                  }

-- -----------------------------------------------------------------------------
--
-- | 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
    :: forall m
    .  GhcMonad m
    => Maybe Messager
    -> HomePackageTable            -- ^ HPT from last time round (pruned)
    -> StableModules               -- ^ stable modules (see checkStability)
    -> [SCC ModuleGraphNode]       -- ^ Mods to do (the worklist)
    -> m (SuccessFlag,
          [ModuleGraphNode])
       -- ^ 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
-> StableModules
-> [SCC ModuleGraphNode]
-> m (SuccessFlag, [ModuleGraphNode])
upsweep Maybe Messager
mHscMessage HomePackageTable
old_hpt StableModules
stable_mods [SCC ModuleGraphNode]
sccs = do
   (SuccessFlag
res, ModuleGraph
done) <- HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
emptyMG [SCC ModuleGraphNode]
sccs Int
1 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModuleGraphNode]
sccs)
   forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
res, forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
done)
 where
  keep_going
    :: [NodeKey]
    -> HomePackageTable
    -> ModuleGraph
    -> [SCC ModuleGraphNode]
    -> Int
    -> Int
    -> m (SuccessFlag, ModuleGraph)
  keep_going :: [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going [NodeKey]
this_mods HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods Int
mod_index Int
nmods = do
    let sum_deps :: [NodeKey] -> SCC ModuleGraphNode -> [NodeKey]
sum_deps [NodeKey]
ms (AcyclicSCC ModuleGraphNode
iuidOrMod) =
          if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges Bool
False ModuleGraphNode
iuidOrMod) forall a b. (a -> b) -> a -> b
$ [NodeKey]
ms
          then ModuleGraphNode -> NodeKey
mkHomeBuildModule ModuleGraphNode
iuidOrMod forall a. a -> [a] -> [a]
: [NodeKey]
ms
          else [NodeKey]
ms
        sum_deps [NodeKey]
ms SCC ModuleGraphNode
_ = [NodeKey]
ms
        dep_closure :: [NodeKey]
dep_closure = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [NodeKey] -> SCC ModuleGraphNode -> [NodeKey]
sum_deps [NodeKey]
this_mods [SCC ModuleGraphNode]
mods
        dropped_ms :: [NodeKey]
dropped_ms = forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
this_mods) (forall a. [a] -> [a]
reverse [NodeKey]
dep_closure)
        prunable :: SCC ModuleGraphNode -> Bool
prunable (AcyclicSCC ModuleGraphNode
node) = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (ModuleGraphNode -> NodeKey
mkHomeBuildModule ModuleGraphNode
node) [NodeKey]
dep_closure
        prunable SCC ModuleGraphNode
_ = Bool
False
        mods' :: [SCC ModuleGraphNode]
mods' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModuleGraphNode -> Bool
prunable) [SCC ModuleGraphNode]
mods
        nmods' :: Int
nmods' = Int
nmods forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeKey]
dropped_ms

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeKey]
dropped_ms) forall a b. (a -> b) -> a -> b
$ do
        DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
        Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
fatalErrorMsg Logger
logger DynFlags
dflags ([NodeKey] -> SDoc
keepGoingPruneErr forall a b. (a -> b) -> a -> b
$ [NodeKey]
dropped_ms)
    (SuccessFlag
_, ModuleGraph
done') <- HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods' (Int
mod_indexforall a. Num a => a -> a -> a
+Int
1) Int
nmods'
    forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done')

  upsweep'
    :: HomePackageTable
    -> ModuleGraph
    -> [SCC ModuleGraphNode]
    -> Int
    -> Int
    -> m (SuccessFlag, ModuleGraph)
  upsweep' :: HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
_old_hpt ModuleGraph
done
     [] Int
_ Int
_
     = forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Succeeded, ModuleGraph
done)

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

  upsweep' HomePackageTable
old_hpt ModuleGraph
done
     (AcyclicSCC (InstantiationNode InstantiatedUnit
iuid) : [SCC ModuleGraphNode]
mods) Int
mod_index Int
nmods
   = do HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe Messager -> Int -> Int -> InstantiatedUnit -> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_index Int
nmods InstantiatedUnit
iuid
        HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods (Int
mod_indexforall a. Num a => a -> a -> a
+Int
1) Int
nmods

  upsweep' HomePackageTable
old_hpt ModuleGraph
done
     (AcyclicSCC (ModuleNode ems :: ExtendedModSummary
ems@(ExtendedModSummary ModSummary
mod [InstantiatedUnit]
_)) : [SCC ModuleGraphNode]
mods) Int
mod_index Int
nmods
   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
        --                     (moduleEnvElts (hsc_HPT hsc_env)))
        let logg :: p -> Maybe SourceError -> m ()
logg p
_mod = WarnErrLogger
defaultWarnErrLogger

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

        -- Remove unwanted tmp files between compilations
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> DynFlags -> IO ()
cleanCurrentModuleTempFiles (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
                                             (HscEnv -> TmpFs
hsc_tmpfs  HscEnv
hsc_env)
                                             (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)

        -- Get ready to tie the knot
        IORef (NameEnv TyThing)
type_env_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef 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 =
                                    forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
mod, IORef (NameEnv TyThing)
type_env_var) }
        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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env1 ModSummary
mod ModuleGraph
done
        forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env2

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

        case Maybe HomeModInfo
mb_mod_info of
          Maybe HomeModInfo
Nothing -> do
                DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
                if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepGoing DynFlags
dflags
                  then [NodeKey]
-> HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
keep_going [ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 ModSummary
mod] HomePackageTable
old_hpt ModuleGraph
done [SCC ModuleGraphNode]
mods Int
mod_index Int
nmods
                  else 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 = 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 -> ExtendedModSummary -> ModuleGraph
extendMG ModuleGraph
done ExtendedModSummary
ems

                        -- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env3 ModSummary
mod ModuleGraph
done'
                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.
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env4) forall a. Eq a => a -> a -> Bool
== Backend
Interpreter) forall a b. (a -> b) -> a -> b
$
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env4
                                 [ SptEntry
spt
                                 | Just Linkable
linkable <- forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Unlinked
unlinked
                                 , SptEntry
spt <- [SptEntry]
spts
                                 ]

                HomePackageTable
-> ModuleGraph
-> [SCC ModuleGraphNode]
-> Int
-> Int
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt1 ModuleGraph
done' [SCC ModuleGraphNode]
mods (Int
mod_indexforall a. Num a => a -> a -> a
+Int
1) Int
nmods

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
    = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

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

-- | Compile a single module.  Always produce a Linkable for it if
-- successful.  If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
            -> Maybe Messager
            -> HomePackageTable
            -> StableModules
            -> ModSummary
            -> Int  -- index of module
            -> Int  -- total number of modules
            -> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> 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 forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj
            is_stable_bco :: Bool
is_stable_bco = ModuleName
this_mod_name 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.
            lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary
            prevailing_backend :: Backend
prevailing_backend = DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
            local_backend :: Backend
local_backend      = DynFlags -> Backend
backend DynFlags
lcl_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.
            bcknd :: Backend
bcknd = case (Backend
prevailing_backend,Backend
local_backend) of
               (Backend
LLVM,Backend
NCG) -> Backend
NCG
               (Backend
NCG,Backend
LLVM) -> Backend
LLVM
               (Backend
NoBackend,Backend
b)
                  | Backend -> Bool
backendProducesObject Backend
b -> Backend
b
               (Backend
Interpreter,Backend
b)
                  | Backend -> Bool
backendProducesObject Backend
b -> Backend
b
               (Backend, Backend)
_ -> Backend
prevailing_backend

            -- store the corrected backend into the summary
            summary' :: ModSummary
summary' = ModSummary
summary{ ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
lcl_dflags { backend :: Backend
backend = Backend
bcknd } }

            -- 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
mb_old_iface
                = case Maybe HomeModInfo
old_hmi of
                     Maybe HomeModInfo
Nothing                                        -> forall a. Maybe a
Nothing
                     Just HomeModInfo
hm_info | ModSummary -> IsBootInterface
isBootSummary ModSummary
summary forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot -> forall a. a -> Maybe a
Just ModIface
iface
                                  | ModIface -> IsBootInterface
mi_boot ModIface
iface forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot        -> forall a. a -> Maybe a
Just ModIface
iface
                                  | Bool
otherwise                       -> forall a. Maybe a
Nothing
                                   where
                                     iface :: ModIface
iface = HomeModInfo -> ModIface
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
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
                             Maybe ModIface
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
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
                             forall a. Maybe a
Nothing Maybe Linkable
mb_linkable SourceModified
src_modified

            -- With NoBackend we create empty linkables to avoid recompilation.
            -- We have to detect these to recompile anyway if the backend 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 =
                  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

            debug_trace :: Int -> SDoc -> IO ()
debug_trace Int
n SDoc
t = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Int
n SDoc
t

        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
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"skipping stable obj mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                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, forall a. Maybe a -> Bool
isNothing Maybe HomeModInfo
old_hmi -> do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling stable on-disk mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Linkable
linkable <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Module -> FilePath -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod FilePath
obj_fn
                              (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"upsweep1" Maybe UTCTime
mb_obj_date)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (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 (Backend -> Bool
backendProducesObject Backend
bcknd), Bool
is_stable_bco,
            (Backend
bcknd forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend) 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
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"skipping stable BCO mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
                -- BCO is stable: nothing to do

          | Bool -> Bool
not (Backend -> Bool
backendProducesObject Backend
bcknd),
            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),
            (Backend
bcknd forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable,
            Linkable -> UTCTime
linkableTime Linkable
l forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
summary -> do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling non-stable BCO mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (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.
          --
          | Backend -> Bool
backendProducesObject Backend
bcknd,
            Just UTCTime
obj_date <- Maybe UTCTime
mb_obj_date,
            UTCTime
obj_date 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 forall a. Eq a => a -> a -> Bool
== UTCTime
obj_date -> do
                          Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod with new on-disk obj:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                          Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
                  Maybe HomeModInfo
_otherwise -> do
                          Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod with new on-disk obj2:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                          Linkable
linkable <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 (forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodified

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

         ()
_otherwise -> do
                Int -> SDoc -> IO ()
debug_trace Int
5 (FilePath -> SDoc
text FilePath
"compiling mod:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
                Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it 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
backend == NoBackend.

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

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

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

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

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

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

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

-- Note [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, 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
                 , 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 [ModuleGraphNode]
loop <- ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
mss Module -> Bool
appearsAsBoot
  -- SOME hs-boot files should still
  -- get used, just not the loop-closer.
  , let non_boot :: [ModSummary]
non_boot = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [ModuleGraphNode]
loop forall a b. (a -> b) -> a -> b
$ \case
          InstantiationNode InstantiatedUnit
_ -> forall a. Maybe a
Nothing
          ModuleNode ExtendedModSummary
ems -> do
            let l :: ModSummary
l = ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ems
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ModSummary -> IsBootInterface
isBootSummary ModSummary
l forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot Bool -> Bool -> Bool
&& ModSummary -> Module
ms_mod ModSummary
l forall a. Eq a => a -> a -> Bool
== ModSummary -> Module
ms_mod ModSummary
ms
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ModSummary
l
  = DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) HscEnv
hsc_env (forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
non_boot)
  | Bool
otherwise
  = forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
  where
  mss :: [ModuleGraphNode]
mss = ModuleGraph -> [ModuleGraphNode]
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
  -> [ModuleGraphNode]
  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'
  -> Maybe [ModuleGraphNode]
getModLoop :: ModSummary
-> [ModuleGraphNode] -> (Module -> Bool) -> Maybe [ModuleGraphNode]
getModLoop ModSummary
ms [ModuleGraphNode]
graph Module -> Bool
appearsAsBoot
  | ModSummary -> IsBootInterface
isBootSummary ModSummary
ms forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot
  , Module -> Bool
appearsAsBoot Module
this_mod
  , let mss :: [ModuleGraphNode]
mss = ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) [ModuleGraphNode]
graph
  = forall a. a -> Maybe a
Just [ModuleGraphNode]
mss
  | Bool
otherwise
  = 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
  Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
2 forall a b. (a -> b) -> a -> b
$
     FilePath -> SDoc
text FilePath
"Re-typechecking loop: " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [ModuleName]
mods
  HomePackageTable
new_hpt <-
    forall a. (a -> IO a) -> IO a
fixIO 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 <- forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
text FilePath
"typecheckLoop") HscEnv
new_hsc_env forall a b. (a -> b) -> a -> b
$
                forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
      let new_hpt :: HomePackageTable
new_hpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt HomePackageTable
old_hpt
                        (forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
mods [ HomeModInfo
hmi{ hm_details :: ModDetails
hm_details = ModDetails
details }
                                  | (HomeModInfo
hmi,ModDetails
details) <- forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds ])
      forall (m :: * -> *) a. Monad m => a -> m a
return HomePackageTable
new_hpt
  forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
  where
    logger :: Logger
logger  = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    old_hpt :: HomePackageTable
old_hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    hmis :: [HomeModInfo]
hmis    = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"typecheckLoop" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt) [ModuleName]
mods

reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
reachableBackwards ModuleName
mod [ModuleGraphNode]
summaries
  = [ forall key payload. Node key payload -> payload
node_payload SummaryNode
node | SummaryNode
node <- forall node. Graph node -> node -> [node]
reachableG (forall node. Graph node -> Graph node
transposeG Graph SummaryNode
graph) SummaryNode
root ]
  where -- the rest just sets up the graph:
        (Graph SummaryNode
graph, NodeKey -> Maybe SummaryNode
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False [ModuleGraphNode]
summaries
        root :: SummaryNode
root  = forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"reachableBackwards" (NodeKey -> Maybe SummaryNode
lookup_node forall a b. (a -> b) -> a -> b
$ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ 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 ModuleGraphNode]
-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
-- The resulting list of strongly-connected-components is in topologically
-- sorted order, starting with the module(s) at the bottom of the
-- dependency graph (ie compile them first) and ending with the ones at
-- the top.
--
-- Drop hi-boot nodes (first boolean arg)?
--
-- - @False@:   treat the hi-boot summaries as nodes of the graph,
--              so the graph must be acyclic
--
-- - @True@:    eliminate the hi-boot nodes, and instead pretend
--              the a source-import of Foo is an import of Foo
--              The resulting graph has no hi-boot nodes, but can be cyclic

topSortModuleGraph :: Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
drop_hs_boot_nodes ModuleGraph
module_graph Maybe ModuleName
mb_root_mod
  = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> ModuleGraphNode
summaryNodeSummary) forall a b. (a -> b) -> a -> b
$ forall node. Graph node -> [SCC node]
stronglyConnCompG Graph SummaryNode
initial_graph
  where
    summaries :: [ModuleGraphNode]
summaries = ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
module_graph
    -- stronglyConnCompG flips the original order, so if we reverse
    -- the summaries we get a stable topological sort.
    (Graph SummaryNode
graph, NodeKey -> Maybe SummaryNode
lookup_node) =
      Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
drop_hs_boot_nodes (forall a. [a] -> [a]
reverse [ModuleGraphNode]
summaries)

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

type SummaryNode = Node Int ModuleGraphNode

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

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

-- | Collect the immediate dependencies of a ModuleGraphNode,
-- optionally avoiding hs-boot dependencies.
-- If the drop_hs_boot_nodes flag is False, and 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.
unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]
unfilteredEdges Bool
drop_hs_boot_nodes = \case
    InstantiationNode InstantiatedUnit
iuid ->
      ModNodeKey -> NodeKey
NodeKey_Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
NotBoot forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. UniqDSet a -> [a]
uniqDSetToList (forall unit. GenInstantiatedUnit unit -> UniqDSet ModuleName
instUnitHoles InstantiatedUnit
iuid)
    ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bds) ->
      (ModNodeKey -> NodeKey
NodeKey_Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
hs_boot_key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
ms) forall a. [a] -> [a] -> [a]
++
      (ModNodeKey -> NodeKey
NodeKey_Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB IsBootInterface
NotBoot     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
ms) forall a. [a] -> [a] -> [a]
++
      [ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot
      | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Bool
drop_hs_boot_nodes Bool -> Bool -> Bool
|| ModSummary -> HscSource
ms_hsc_src ModSummary
ms forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
      ] forall a. [a] -> [a] -> [a]
++
      [ InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
inst_unit
      | InstantiatedUnit
inst_unit <- [InstantiatedUnit]
bds
      ]
  where
    -- 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 -> [ModuleGraphNode]
  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes :: Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries =
  (forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [SummaryNode]
nodes, NodeKey -> Maybe SummaryNode
lookup_node)
  where
    numbered_summaries :: [(ModuleGraphNode, Int)]
numbered_summaries = forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleGraphNode]
summaries [Int
1..]

    lookup_node :: NodeKey -> Maybe SummaryNode
    lookup_node :: NodeKey -> Maybe SummaryNode
lookup_node NodeKey
key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
key (forall a. NodeMap a -> Map NodeKey a
unNodeMap NodeMap SummaryNode
node_map)

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

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

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

    out_edge_keys :: [NodeKey] -> [Int]
    out_edge_keys :: [NodeKey] -> [Int]
out_edge_keys = 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 for the current
-- modules, and indefinite unit IDs for dependencies which are instantiated with
-- our holes.
--
-- NB: hsig files show up as *normal* nodes (not boot!), since they don't
-- participate in cycles (for now)
type ModNodeKey = ModuleNameWithIsBoot
newtype ModNodeMap a = ModNodeMap { forall a. ModNodeMap a -> Map ModNodeKey a
unModNodeMap :: Map.Map ModNodeKey a }
  deriving (forall a b. a -> ModNodeMap b -> ModNodeMap a
forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
$c<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
fmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
$cfmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
Functor, Functor ModNodeMap
Foldable ModNodeMap
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
sequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
Traversable, forall a. Eq a => a -> ModNodeMap a -> Bool
forall a. Num a => ModNodeMap a -> a
forall a. Ord a => ModNodeMap a -> a
forall m. Monoid m => ModNodeMap m -> m
forall a. ModNodeMap a -> Bool
forall a. ModNodeMap a -> Int
forall a. ModNodeMap a -> [a]
forall a. (a -> a -> a) -> ModNodeMap a -> a
forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => ModNodeMap a -> a
$cproduct :: forall a. Num a => ModNodeMap a -> a
sum :: forall a. Num a => ModNodeMap a -> a
$csum :: forall a. Num a => ModNodeMap a -> a
minimum :: forall a. Ord a => ModNodeMap a -> a
$cminimum :: forall a. Ord a => ModNodeMap a -> a
maximum :: forall a. Ord a => ModNodeMap a -> a
$cmaximum :: forall a. Ord a => ModNodeMap a -> a
elem :: forall a. Eq a => a -> ModNodeMap a -> Bool
$celem :: forall a. Eq a => a -> ModNodeMap a -> Bool
length :: forall a. ModNodeMap a -> Int
$clength :: forall a. ModNodeMap a -> Int
null :: forall a. ModNodeMap a -> Bool
$cnull :: forall a. ModNodeMap a -> Bool
toList :: forall a. ModNodeMap a -> [a]
$ctoList :: forall a. ModNodeMap a -> [a]
foldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
fold :: forall m. Monoid m => ModNodeMap m -> m
$cfold :: forall m. Monoid m => ModNodeMap m -> m
Foldable)

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

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

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

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

data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey
  deriving (NodeKey -> NodeKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeKey -> NodeKey -> Bool
$c/= :: NodeKey -> NodeKey -> Bool
== :: NodeKey -> NodeKey -> Bool
$c== :: NodeKey -> NodeKey -> Bool
Eq, Eq NodeKey
NodeKey -> NodeKey -> Bool
NodeKey -> NodeKey -> Ordering
NodeKey -> NodeKey -> NodeKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NodeKey -> NodeKey -> NodeKey
$cmin :: NodeKey -> NodeKey -> NodeKey
max :: NodeKey -> NodeKey -> NodeKey
$cmax :: NodeKey -> NodeKey -> NodeKey
>= :: NodeKey -> NodeKey -> Bool
$c>= :: NodeKey -> NodeKey -> Bool
> :: NodeKey -> NodeKey -> Bool
$c> :: NodeKey -> NodeKey -> Bool
<= :: NodeKey -> NodeKey -> Bool
$c<= :: NodeKey -> NodeKey -> Bool
< :: NodeKey -> NodeKey -> Bool
$c< :: NodeKey -> NodeKey -> Bool
compare :: NodeKey -> NodeKey -> Ordering
$ccompare :: NodeKey -> NodeKey -> Ordering
Ord)

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

msKey :: ModSummary -> ModNodeKey
msKey :: ModSummary -> ModNodeKey
msKey = ModSummary -> ModNodeKey
mkHomeBuildModule0

mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
  InstantiationNode InstantiatedUnit
x -> InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
x
  ModuleNode ExtendedModSummary
x -> ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ ModSummary -> ModNodeKey
mkHomeBuildModule0 (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
x)

pprNodeKey :: NodeKey -> SDoc
pprNodeKey :: NodeKey -> SDoc
pprNodeKey (NodeKey_Unit InstantiatedUnit
iu) = forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
iu
pprNodeKey (NodeKey_Module ModNodeKey
mk) = forall a. Outputable a => a -> SDoc
ppr ModNodeKey
mk

mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap [ExtendedModSummary]
summaries = forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (ModSummary -> ModNodeKey
msKey forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
s, ExtendedModSummary
s) | ExtendedModSummary
s <- [ExtendedModSummary]
summaries]

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

        warn :: Located ModuleName -> WarnMsg
        warn :: GenLocated SrcSpan ModuleName -> MsgEnvelope DecoratedSDoc
warn (L SrcSpan
loc ModuleName
mod) =
           SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc
                (FilePath -> SDoc
text FilePath
"Warning: {-# SOURCE #-} unnecessary in import of "
                 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (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
          -> [ExtendedModSummary]
          -- ^ 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 ExtendedModSummary]
                -- The non-error elements of the returned list all have distinct
                -- (Modules, IsBoot) identifiers, unless the Bool is true in
                -- which case there can be repeats
downsweep :: HscEnv
-> [ExtendedModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ExtendedModSummary]
downsweep HscEnv
hsc_env [ExtendedModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots
   = do
       [Either ErrorMessages ExtendedModSummary]
rootSummaries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Target -> IO (Either ErrorMessages ExtendedModSummary)
getRootSummary [Target]
roots
       let ([ErrorMessages]
errs, [ExtendedModSummary]
rootSummariesOk) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ExtendedModSummary]
rootSummaries -- #17549
           root_map :: ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map = [ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap [ExtendedModSummary]
rootSummariesOk
       ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO ()
checkDuplicates ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
       ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0 <- [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
loop (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ExtendedModSummary
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps [ExtendedModSummary]
rootSummariesOk) ModNodeMap [Either ErrorMessages ExtendedModSummary]
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
       let default_backend :: Backend
default_backend = Platform -> Backend
platformDefaultBackend (DynFlags -> Platform
targetPlatform DynFlags
dflags)
       let home_unit :: HomeUnit
home_unit       = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
       let tmpfs :: TmpFs
tmpfs           = HscEnv -> TmpFs
hsc_tmpfs     HscEnv
hsc_env
       ModNodeMap [Either ErrorMessages ExtendedModSummary]
map1 <- case DynFlags -> Backend
backend DynFlags
dflags of
         Backend
NoBackend   -> Logger
-> TmpFs
-> HomeUnit
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH Logger
logger TmpFs
tmpfs HomeUnit
home_unit Backend
default_backend ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0
         Backend
_           -> forall (m :: * -> *) a. Monad m => a -> m a
return ModNodeMap [Either ErrorMessages ExtendedModSummary]
map0
       if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMessages]
errs
         then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
map1
         else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [ErrorMessages]
errs
     where
        -- TODO(@Ericson2314): Probably want to include backpack instantiations
        -- in the map eventually for uniformity
        calcDeps :: ExtendedModSummary
-> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
calcDeps (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_bkp_deps) = ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
ms

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

        old_summary_map :: ModNodeMap ExtendedModSummary
        old_summary_map :: ModNodeMap ExtendedModSummary
old_summary_map = [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
mkNodeMap [ExtendedModSummary]
old_summaries

        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)
        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)
getRootSummary (Target (TargetFile FilePath
file Maybe Phase
mb_phase) Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf)
           = do Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
file
                if Bool
exists Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe (InputFileBuffer, UTCTime)
maybe_buf
                    then HscEnv
-> [ExtendedModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ExtendedModSummary)
summariseFile HscEnv
hsc_env [ExtendedModSummary]
old_summaries FilePath
file Maybe Phase
mb_phase
                                       Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf
                    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan 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 ExtendedModSummary)
maybe_summary <- HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env ModNodeMap ExtendedModSummary
old_summary_map IsBootInterface
NotBoot
                                           (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 ExtendedModSummary)
maybe_summary of
                   Maybe (Either ErrorMessages ExtendedModSummary)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ModuleName -> ErrorMessages
moduleNotFoundErr ModuleName
modl
                   Just Either ErrorMessages ExtendedModSummary
s  -> forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorMessages ExtendedModSummary
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
          :: ModNodeMap
               [Either ErrorMessages
                       ExtendedModSummary]
          -> IO ()
        checkDuplicates :: ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO ()
checkDuplicates ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map
           | Bool
allow_dup_roots = forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ExtendedModSummary]]
dup_roots  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | Bool
otherwise       = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [ModSummary] -> IO ()
multiRootsErr (ExtendedModSummary -> ModSummary
emsModSummary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> a
head [[ExtendedModSummary]]
dup_roots)
           where
             dup_roots :: [[ExtendedModSummary]]        -- Each at least of length 2
             dup_roots :: [[ExtendedModSummary]]
dup_roots = forall a. (a -> Bool) -> [a] -> [a]
filterOut forall a. [a] -> Bool
isSingleton forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. [Either a b] -> [b]
rights forall a b. (a -> b) -> a -> b
$ forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
root_map

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

-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
-- the specified target, disable optimization and change the .hi
-- and .o file locations to be temporary files.
-- See Note [-fno-code mode]
enableCodeGenForTH
  :: Logger
  -> TmpFs
  -> HomeUnit
  -> Backend
  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH :: Logger
-> TmpFs
-> HomeUnit
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenForTH Logger
logger TmpFs
tmpfs HomeUnit
home_unit =
  Logger
-> TmpFs
-> (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen Logger
logger TmpFs
tmpfs ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
TFL_CurrentModule TempFileLifetime
TFL_GhcSession
  where
    condition :: ModSummary -> Bool
condition = ModSummary -> Bool
isTemplateHaskellOrQQNonBoot
    should_modify :: ModSummary -> Bool
should_modify (ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
      DynFlags -> Backend
backend DynFlags
dflags forall a. Eq a => a -> a -> Bool
== Backend
NoBackend Bool -> Bool -> Bool
&&
      -- Don't enable codegen for TH on indefinite packages; we
      -- can't compile anything anyway! See #16219.
      forall u. GenHomeUnit u -> Bool
isHomeUnitDefinite HomeUnit
home_unit

-- | Helper used to implement 'enableCodeGenForTH'.
-- In particular, this enables
-- unoptimized code generation for all modules that meet some
-- condition (first parameter), or are dependencies of those
-- modules. The second parameter is a condition to check before
-- marking modules for code generation.
enableCodeGenWhen
  :: Logger
  -> TmpFs
  -> (ModSummary -> Bool)
  -> (ModSummary -> Bool)
  -> TempFileLifetime
  -> TempFileLifetime
  -> Backend
  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen :: Logger
-> TmpFs
-> (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> Backend
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
-> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
enableCodeGenWhen Logger
logger TmpFs
tmpfs ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
staticLife TempFileLifetime
dynLife Backend
bcknd ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap =
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ExtendedModSummary -> IO ExtendedModSummary
enable_code_gen)) ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
  where
    enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
    enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
enable_code_gen (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bkp_deps)
      | ModSummary
        { ms_mod :: ModSummary -> Module
ms_mod = Module
ms_mod
        , ms_location :: ModSummary -> ModLocation
ms_location = ModLocation
ms_location
        , ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
HsSrcFile
        , ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags
        } <- ModSummary
ms
      , ModSummary -> Bool
should_modify ModSummary
ms
      , Module
ms_mod forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
needs_codegen_set
      = do
        let new_temp_file :: FilePath -> FilePath -> IO FilePath
new_temp_file FilePath
suf FilePath
dynsuf = do
              FilePath
tn <- Logger
-> TmpFs -> DynFlags -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs DynFlags
dflags TempFileLifetime
staticLife FilePath
suf
              let dyn_tn :: FilePath
dyn_tn = FilePath
tn FilePath -> FilePath -> FilePath
-<.> FilePath
dynsuf
              TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
dynLife [FilePath
dyn_tn]
              forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
tn
          -- We don't want to create .o or .hi files unless we have been asked
          -- to by the user. But we need them, so we patch their locations in
          -- the ModSummary with temporary files.
          --
        (FilePath
hi_file, FilePath
o_file) <-
          -- If ``-fwrite-interface` is specified, then the .o and .hi files
          -- are written into `-odir` and `-hidir` respectively.  #16670
          if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
            then forall (m :: * -> *) a. Monad m => a -> m a
return (ModLocation -> FilePath
ml_hi_file ModLocation
ms_location, ModLocation -> FilePath
ml_obj_file ModLocation
ms_location)
            else (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO FilePath
new_temp_file (DynFlags -> FilePath
hiSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynHiSuf_ DynFlags
dflags))
                     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> FilePath -> IO FilePath
new_temp_file (DynFlags -> FilePath
objectSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynObjectSuf_ DynFlags
dflags))
        let ms' :: ModSummary
ms' = ModSummary
ms
              { ms_location :: ModLocation
ms_location =
                  ModLocation
ms_location {ml_hi_file :: FilePath
ml_hi_file = FilePath
hi_file, ml_obj_file :: FilePath
ml_obj_file = FilePath
o_file}
              , ms_hspp_opts :: DynFlags
ms_hspp_opts = Int -> DynFlags -> DynFlags
updOptLevel Int
0 forall a b. (a -> b) -> a -> b
$ DynFlags
dflags {backend :: Backend
backend = Backend
bcknd}
              }
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModSummary -> [InstantiatedUnit] -> ExtendedModSummary
ExtendedModSummary ModSummary
ms' [InstantiatedUnit]
bkp_deps)
      | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> [InstantiatedUnit] -> ExtendedModSummary
ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bkp_deps)

    needs_codegen_set :: Set Module
needs_codegen_set = [ModSummary] -> Set Module
transitive_deps_set
      [ ModSummary
ms
      | [Either ErrorMessages ExtendedModSummary]
mss <- forall a. ModNodeMap a -> [a]
modNodeMapElems ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
      , Right (ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
ms }) <- [Either ErrorMessages ExtendedModSummary]
mss
      , ModSummary -> Bool
condition ModSummary
ms
      ]

    -- find the set of all transitive dependencies of a list of modules.
    transitive_deps_set :: [ModSummary] -> Set.Set Module
    transitive_deps_set :: [ModSummary] -> Set Module
transitive_deps_set [ModSummary]
modSums = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go forall a. Set a
Set.empty [ModSummary]
modSums
      where
        go :: Set Module -> ModSummary -> Set Module
go Set Module
marked_mods ms :: ModSummary
ms@ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod}
          | Module
ms_mod forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
marked_mods = Set Module
marked_mods
          | Bool
otherwise =
            let deps :: [ModSummary]
deps =
                  [ ModSummary
dep_ms
                  -- If a module imports a boot module, msDeps helpfully adds a
                  -- dependency to that non-boot module in it's result. This
                  -- means we don't have to think about boot modules here.
                  | GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep <- ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
ms
                  , IsBootInterface
NotBoot forall a. Eq a => a -> a -> Bool
== forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep
                  , [Either ErrorMessages ExtendedModSummary]
dep_ms_0 <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenWithIsBoot (GenLocated SrcSpan ModuleName)
dep) ModNodeMap [Either ErrorMessages ExtendedModSummary]
nodemap
                  , Either ErrorMessages ExtendedModSummary
dep_ms_1 <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ [Either ErrorMessages ExtendedModSummary]
dep_ms_0
                  , (ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
dep_ms }) <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Either ErrorMessages ExtendedModSummary
dep_ms_1
                  ]
                new_marked_mods :: Set Module
new_marked_mods = forall a. Ord a => a -> Set a -> Set a
Set.insert Module
ms_mod Set Module
marked_mods
            in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go Set Module
new_marked_mods [ModSummary]
deps

mkRootMap
  :: [ExtendedModSummary]
  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap :: [ExtendedModSummary]
-> ModNodeMap [Either ErrorMessages ExtendedModSummary]
mkRootMap [ExtendedModSummary]
summaries = forall a. Map ModNodeKey a -> ModNodeMap a
ModNodeMap forall a b. (a -> b) -> a -> b
$ forall key elt.
Ord key =>
(elt -> elt -> elt) -> [(key, elt)] -> Map key elt -> Map key elt
Map.insertListWith
  (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> [a] -> [a]
(++))
  [ (ModSummary -> ModNodeKey
msKey forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
s, [forall a b. b -> Either a b
Right ExtendedModSummary
s]) | ExtendedModSummary
s <- [ExtendedModSummary]
summaries ]
  forall k a. Map k a
Map.empty

-- | Returns the dependencies of the ModSummary s.
-- A wrinkle is that for a {-# SOURCE #-} import we return
--      *both* the hs-boot file
--      *and* the source file
-- as "dependencies".  That ensures that the list of all relevant
-- modules always contains B.hs if it contains B.hs-boot.
-- Remember, this pass isn't doing the topological sort.  It's
-- just gathering the list of all relevant ModSummaries
msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]
msDeps :: ModSummary -> [GenWithIsBoot (GenLocated SrcSpan ModuleName)]
msDeps ModSummary
s = [ GenWithIsBoot (GenLocated SrcSpan ModuleName)
d
           | GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
s
           , GenWithIsBoot (GenLocated SrcSpan ModuleName)
d <- [ GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
IsBoot }
                  , GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
                  ]
           ]
        forall a. [a] -> [a] -> [a]
++ [ GWIB { gwib_mod :: GenLocated SrcSpan ModuleName
gwib_mod = GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
           | GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps ModSummary
s
           ]

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

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

summariseFile
        :: HscEnv
        -> [ExtendedModSummary]         -- old summaries
        -> FilePath                     -- source file name
        -> Maybe Phase                  -- start phase
        -> Bool                         -- object code allowed?
        -> Maybe (StringBuffer,UTCTime)
        -> IO (Either ErrorMessages ExtendedModSummary)

summariseFile :: HscEnv
-> [ExtendedModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ExtendedModSummary)
summariseFile HscEnv
hsc_env [ExtendedModSummary]
old_summaries FilePath
src_fn Maybe Phase
mb_phase Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf
        -- we can use a cached summary if one is available and the
        -- source file hasn't changed,  But we have to look up the summary
        -- by source file, rather than module name as we do in summarise.
   | Just ExtendedModSummary
old_summary <- [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile [ExtendedModSummary]
old_summaries FilePath
src_fn
   = do
        let location :: ModLocation
location = ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary
            dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

        UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
                -- The file exists; we checked in getRootSummary above.
                -- If it gets removed subsequently, then this
                -- getModificationUTCTime may fail, but that's the right
                -- behaviour.

                -- return the cached summary if the source didn't change
        forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
            HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
NotBoot (FilePath -> UTCTime -> IO (Either ErrorMessages ExtendedModSummary)
new_summary FilePath
src_fn)
            ExtendedModSummary
old_summary ModLocation
location UTCTime
src_timestamp

   | Bool
otherwise
   = do UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
        FilePath -> UTCTime -> IO (Either ErrorMessages ExtendedModSummary)
new_summary FilePath
src_fn UTCTime
src_timestamp
  where
    get_src_timestamp :: IO UTCTime
get_src_timestamp = case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
                           Just (InputFileBuffer
_,UTCTime
t) -> forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
                           Maybe (InputFileBuffer, UTCTime)
Nothing    -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO UTCTime
getModificationUTCTime FilePath
src_fn
                        -- getModificationUTCTime may fail

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


        -- Make a ModLocation for this file
        ModLocation
location <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) ModuleName
pi_mod_name FilePath
src_fn

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

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

findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
findSummaryBySourceFile [ExtendedModSummary]
summaries FilePath
file = case
    [ ExtendedModSummary
ms
    | ExtendedModSummary
ms <- [ExtendedModSummary]
summaries
    , HscSource
HsSrcFile <- [ModSummary -> HscSource
ms_hsc_src forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ms]
    , let derived_file :: Maybe FilePath
derived_file = ModLocation -> Maybe FilePath
ml_hs_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
ms
    , forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"findSummaryBySourceFile" Maybe FilePath
derived_file forall a. Eq a => a -> a -> Bool
== FilePath
file
    ]
  of
    [] -> forall a. Maybe a
Nothing
    (ExtendedModSummary
x:[ExtendedModSummary]
_) -> forall a. a -> Maybe a
Just ExtendedModSummary
x

checkSummaryTimestamp
    :: HscEnv -> DynFlags -> Bool -> IsBootInterface
    -> (UTCTime -> IO (Either e ExtendedModSummary))
    -> ExtendedModSummary -> ModLocation -> UTCTime
    -> IO (Either e ExtendedModSummary)
checkSummaryTimestamp :: forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
  HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
is_boot UTCTime -> IO (Either e ExtendedModSummary)
new_summary
  (ExtendedModSummary { emsModSummary :: ExtendedModSummary -> ModSummary
emsModSummary = ModSummary
old_summary, emsInstantiatedUnits :: ExtendedModSummary -> [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
bkp_deps})
  ModLocation
location UTCTime
src_timestamp
  | ModSummary -> UTCTime
ms_hs_date ModSummary
old_summary forall a. Eq a => a -> a -> Bool
== UTCTime
src_timestamp Bool -> Bool -> Bool
&&
      Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = do
           -- update the object-file timestamp
           Maybe UTCTime
obj_timestamp <-
             if Backend -> Bool
backendProducesObject (DynFlags -> Backend
backend (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
                 Bool -> Bool -> Bool
|| Bool
obj_allowed -- bug #1205
                 then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBootInterface
is_boot
                 else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

           -- We have to repopulate the Finder's cache for file targets
           -- because the file might not even be on the regular search path
           -- and it was likely flushed in depanal. This is not technically
           -- needed when we're called from sumariseModule but it shouldn't
           -- hurt.
           Module
_ <- HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env
                  (forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
old_summary)) ModLocation
location

           Maybe UTCTime
hi_timestamp <- DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
location
           Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)

           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
             ( ExtendedModSummary { emsModSummary :: ModSummary
emsModSummary = ModSummary
old_summary
                     { ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
                     , ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
                     , ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
                     }
                   , emsInstantiatedUnits :: [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
bkp_deps
                   }
             )

   | Bool
otherwise =
           -- source changed: re-summarise.
           UTCTime -> IO (Either e ExtendedModSummary)
new_summary UTCTime
src_timestamp

-- Summarise a module, and pick up source and timestamp.
summariseModule
          :: HscEnv
          -> ModNodeMap ExtendedModSummary
          -- ^ Map of old summaries
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Located ModuleName -- Imported module to be summarised
          -> Bool               -- object code allowed?
          -> Maybe (StringBuffer, UTCTime)
          -> [ModuleName]               -- Modules to exclude
          -> IO (Maybe (Either ErrorMessages ExtendedModSummary))      -- Its new summary

summariseModule :: HscEnv
-> ModNodeMap ExtendedModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ExtendedModSummary))
summariseModule HscEnv
hsc_env ModNodeMap ExtendedModSummary
old_summary_map IsBootInterface
is_boot (L SrcSpan
loc ModuleName
wanted_mod)
                Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
  | ModuleName
wanted_mod forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
excl_mods
  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  | Just ExtendedModSummary
old_summary <- forall a. ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup
      (GWIB { gwib_mod :: ModuleName
gwib_mod = ModuleName
wanted_mod, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
is_boot })
      ModNodeMap ExtendedModSummary
old_summary_map
  = do          -- Find its new timestamp; all the
                -- ModSummaries in the old map have valid ml_hs_files
        let location :: ModLocation
location = ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary
            src_fn :: FilePath
src_fn = forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"summariseModule" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location)

                -- check the modification time on the source file, and
                -- return the cached summary if it hasn't changed.  If the
                -- file has disappeared, we need to call the Finder again.
        case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
           Just (InputFileBuffer
_,UTCTime
t) ->
               forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn UTCTime
t
           Maybe (InputFileBuffer, UTCTime)
Nothing    -> do
                Either IOException UTCTime
m <- forall a. IO a -> IO (Either IOException a)
tryIO (FilePath -> IO UTCTime
getModificationUTCTime FilePath
src_fn)
                case Either IOException UTCTime
m of
                   Right UTCTime
t ->
                       forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn UTCTime
t
                   Left IOException
e | IOException -> Bool
isDoesNotExistError IOException
e -> IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it
                          | Bool
otherwise             -> forall a. IOException -> IO a
ioError IOException
e

  | Bool
otherwise  = IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env

    check_timestamp :: ExtendedModSummary
-> ModLocation
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
check_timestamp ExtendedModSummary
old_summary ModLocation
location FilePath
src_fn =
        forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBootInterface
-> (UTCTime -> IO (Either e ExtendedModSummary))
-> ExtendedModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ExtendedModSummary)
checkSummaryTimestamp
          HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBootInterface
is_boot
          (ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location (ModSummary -> Module
ms_mod forall a b. (a -> b) -> a -> b
$ ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
old_summary) FilePath
src_fn)
          ExtendedModSummary
old_summary ModLocation
location

    find_it :: IO (Maybe (Either ErrorMessages ExtendedModSummary))
find_it = do
        FindResult
found <- HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
wanted_mod forall a. Maybe a
Nothing
        case FindResult
found of
             Found ModLocation
location Module
mod
                | forall a. Maybe a -> Bool
isJust (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location) ->
                        -- Home package
                         forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModLocation
-> Module -> IO (Either ErrorMessages ExtendedModSummary)
just_found ModLocation
location Module
mod

             FindResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                        -- Not found
                        -- (If it is TRULY not found at all, we'll
                        -- error when we actually try to compile)

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

                -- Check that it exists
                -- It might have been deleted since the Finder last found it
        Maybe UTCTime
maybe_t <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists FilePath
src_fn
        case Maybe UTCTime
maybe_t of
          Maybe UTCTime
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> FilePath -> ErrorMessages
noHsFileErr SrcSpan
loc FilePath
src_fn
          Just UTCTime
t  -> ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location' Module
mod FilePath
src_fn UTCTime
t

    new_summary :: ModLocation
-> Module
-> FilePath
-> UTCTime
-> IO (Either ErrorMessages ExtendedModSummary)
new_summary ModLocation
location Module
mod FilePath
src_fn UTCTime
src_timestamp
      = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
        preimps :: PreprocessedImports
preimps@PreprocessedImports {FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..}
            <- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn forall a. Maybe a
Nothing Maybe (InputFileBuffer, UTCTime)
maybe_buf

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

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
pi_mod_name forall a. Eq a => a -> a -> Bool
/= ModuleName
wanted_mod) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
pi_mod_name_loc forall a b. (a -> b) -> a -> b
$
                              FilePath -> SDoc
text FilePath
"File name does not match module name:"
                              SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
"Saw:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
                              SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
"Expected:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
wanted_mod)

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name (forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit))) forall a b. (a -> b) -> a -> b
$
            let suggested_instantiated_with :: SDoc
suggested_instantiated_with =
                    [SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall a b. (a -> b) -> a -> b
$
                        [ forall a. Outputable a => a -> SDoc
ppr ModuleName
k SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Module
v
                        | (ModuleName
k,Module
v) <- ((ModuleName
pi_mod_name, forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule ModuleName
pi_mod_name)
                                forall a. a -> [a] -> [a]
: forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit)
                        ])
            in forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
pi_mod_name_loc forall a b. (a -> b) -> a -> b
$
                FilePath -> SDoc
text FilePath
"Unexpected signature:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
                SDoc -> SDoc -> SDoc
$$ if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildingCabalPackage DynFlags
dflags
                    then SDoc -> SDoc
parens (FilePath -> SDoc
text FilePath
"Try adding" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
                            SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"to the"
                            SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FilePath -> SDoc
text FilePath
"signatures")
                            SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"field in your Cabal file.")
                    else SDoc -> SDoc
parens (FilePath -> SDoc
text FilePath
"Try passing -instantiated-with=\"" SDoc -> SDoc -> SDoc
<>
                                 SDoc
suggested_instantiated_with SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"\"" SDoc -> SDoc -> SDoc
$$
                                FilePath -> SDoc
text FilePath
"replacing <" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text FilePath
"> as necessary.")

        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
            { nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
            , nms_src_timestamp :: UTCTime
nms_src_timestamp = UTCTime
src_timestamp
            , nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
is_boot
            , nms_hsc_src :: HscSource
nms_hsc_src = HscSource
hsc_src
            , nms_location :: ModLocation
nms_location = ModLocation
location
            , nms_mod :: Module
nms_mod = Module
mod
            , nms_obj_allowed :: Bool
nms_obj_allowed = Bool
obj_allowed
            , nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
            }

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

makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
makeNewModSummary HscEnv
hsc_env MakeNewModSummary{Bool
FilePath
UTCTime
Module
IsBootInterface
ModLocation
HscSource
PreprocessedImports
nms_preimps :: PreprocessedImports
nms_obj_allowed :: Bool
nms_mod :: Module
nms_location :: ModLocation
nms_hsc_src :: HscSource
nms_is_boot :: IsBootInterface
nms_src_timestamp :: UTCTime
nms_src_fn :: FilePath
nms_preimps :: MakeNewModSummary -> PreprocessedImports
nms_obj_allowed :: MakeNewModSummary -> Bool
nms_mod :: MakeNewModSummary -> Module
nms_location :: MakeNewModSummary -> ModLocation
nms_hsc_src :: MakeNewModSummary -> HscSource
nms_is_boot :: MakeNewModSummary -> IsBootInterface
nms_src_timestamp :: MakeNewModSummary -> UTCTime
nms_src_fn :: MakeNewModSummary -> FilePath
..} = do
  let PreprocessedImports{FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_theimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..} = PreprocessedImports
nms_preimps
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  -- when the user asks to load a source file by name, we only
  -- use an object file if -fobject-code is on.  See #1205.
  Maybe UTCTime
obj_timestamp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      if Backend -> Bool
backendProducesObject (DynFlags -> Backend
backend DynFlags
dflags)
         Bool -> Bool -> Bool
|| Bool
nms_obj_allowed -- bug #1205
          then ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
nms_location IsBootInterface
nms_is_boot
          else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  Maybe UTCTime
hi_timestamp <- DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
nms_location
  Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
nms_location)

  [(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports <- HscEnv
-> HscSource
-> ModuleName
-> IO [(Maybe FastString, GenLocated SrcSpan ModuleName)]
findExtraSigImports HscEnv
hsc_env HscSource
nms_hsc_src ModuleName
pi_mod_name
  ([ModuleName]
implicit_sigs, [InstantiatedUnit]
inst_deps) <- HscEnv
-> [(Maybe FastString, GenLocated SrcSpan ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow HscEnv
hsc_env [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExtendedModSummary
    { emsModSummary :: ModSummary
emsModSummary =
        ModSummary
        { ms_mod :: Module
ms_mod = Module
nms_mod
        , ms_hsc_src :: HscSource
ms_hsc_src = HscSource
nms_hsc_src
        , ms_location :: ModLocation
ms_location = ModLocation
nms_location
        , ms_hspp_file :: FilePath
ms_hspp_file = FilePath
pi_hspp_fn
        , ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
pi_local_dflags
        , ms_hspp_buf :: Maybe InputFileBuffer
ms_hspp_buf  = forall a. a -> Maybe a
Just InputFileBuffer
pi_hspp_buf
        , ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = forall a. Maybe a
Nothing
        , ms_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_srcimps = [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps
        , ms_textual_imps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
ms_textual_imps =
            [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps forall a. [a] -> [a] -> [a]
++
            [(Maybe FastString, GenLocated SrcSpan ModuleName)]
extra_sig_imports forall a. [a] -> [a] -> [a]
++
            ((,) forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs)
        , ms_hs_date :: UTCTime
ms_hs_date = UTCTime
nms_src_timestamp
        , ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
        , ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
        , ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
        }
    , emsInstantiatedUnits :: [InstantiatedUnit]
emsInstantiatedUnits = [InstantiatedUnit]
inst_deps
    }

getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBootInterface
is_boot
  = case IsBootInterface
is_boot of
      IsBootInterface
IsBoot -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      IsBootInterface
NotBoot -> FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
location)

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

-- Preprocess the source file and get its imports
-- The pi_local_dflags contains the OPTIONS pragmas
getPreprocessedImports
    :: HscEnv
    -> FilePath
    -> Maybe Phase
    -> Maybe (StringBuffer, UTCTime)
    -- ^ optional source code buffer and modification time
    -> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports :: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf = do
  (DynFlags
pi_local_dflags, FilePath
pi_hspp_fn)
      <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
src_fn (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (InputFileBuffer, UTCTime)
maybe_buf) Maybe Phase
mb_phase
  InputFileBuffer
pi_hspp_buf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
pi_hspp_fn
  ([(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps, [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_theimps, L SrcSpan
pi_mod_name_loc ModuleName
pi_mod_name)
      <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
          let imp_prelude :: Bool
imp_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
pi_local_dflags
              popts :: ParserOpts
popts = DynFlags -> ParserOpts
initParserOpts DynFlags
pi_local_dflags
          Either
  (Bag PsError)
  ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
   [(Maybe FastString, GenLocated SrcSpan ModuleName)],
   GenLocated SrcSpan ModuleName)
mimps <- ParserOpts
-> Bool
-> InputFileBuffer
-> FilePath
-> FilePath
-> IO
     (Either
        (Bag PsError)
        ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
         [(Maybe FastString, GenLocated SrcSpan ModuleName)],
         GenLocated SrcSpan ModuleName))
getImports ParserOpts
popts Bool
imp_prelude InputFileBuffer
pi_hspp_buf FilePath
pi_hspp_fn FilePath
src_fn
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError) Either
  (Bag PsError)
  ([(Maybe FastString, GenLocated SrcSpan ModuleName)],
   [(Maybe FastString, GenLocated SrcSpan ModuleName)],
   GenLocated SrcSpan ModuleName)
mimps)
  forall (m :: * -> *) a. Monad m => a -> m a
return PreprocessedImports {FilePath
[(Maybe FastString, GenLocated SrcSpan ModuleName)]
ModuleName
DynFlags
InputFileBuffer
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_local_dflags :: DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_theimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(Maybe FastString, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}


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

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

    let deferDiagnostics :: LogAction
deferDiagnostics DynFlags
_dflags !WarnReason
reason !Severity
severity !SrcSpan
srcSpan !SDoc
msg = do
          let action :: IO ()
action = Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
          case Severity
severity of
            Severity
SevWarning -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
warnings forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
            Severity
SevError -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
errors forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
            Severity
SevFatal -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
fatals forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
            Severity
_ -> IO ()
action

        printDeferredDiagnostics :: m ()
printDeferredDiagnostics = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IORef [IO ()]
warnings, IORef [IO ()]
errors, IORef [IO ()]
fatals] forall a b. (a -> b) -> a -> b
$ \IORef [IO ()]
ref -> do
            -- This IORef can leak when the dflags leaks, so let us always
            -- reset the content.
            [IO ()]
actions <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
ref forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> ([], [IO ()]
i)
            forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [IO ()]
actions

    forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
      (forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
pushLogHookM (forall a b. a -> b -> a
const LogAction
deferDiagnostics))
      (\()
_ -> forall (m :: * -> *). GhcMonad m => m ()
popLogHookM forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
printDeferredDiagnostics)
      (\()
_ -> m a
f)

noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc
-- ToDo: we don't have a proper line number for this error
noModError :: HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc
noModError HscEnv
hsc_env SrcSpan
loc ModuleName
wanted_mod FindResult
err
  = SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
wanted_mod FindResult
err

noHsFileErr :: SrcSpan -> String -> ErrorMessages
noHsFileErr :: SrcSpan -> FilePath -> ErrorMessages
noHsFileErr SrcSpan
loc FilePath
path
  = forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
text FilePath
"Can't find" SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
path

moduleNotFoundErr :: ModuleName -> ErrorMessages
moduleNotFoundErr :: ModuleName -> ErrorMessages
moduleNotFoundErr ModuleName
mod
  = forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
        FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr ModuleName
mod) SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
"cannot be found locally"

multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = forall a. FilePath -> a
panic FilePath
"multiRootsErr"
multiRootsErr summs :: [ModSummary]
summs@(ModSummary
summ1:[ModSummary]
_)
  = forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope DecoratedSDoc -> io a
throwOneError forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
        FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Module
mod) SDoc -> SDoc -> SDoc
<+>
        FilePath -> SDoc
text FilePath
"is defined in multiple files:" SDoc -> SDoc -> SDoc
<+>
        [SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> SDoc
text [FilePath]
files)
  where
    mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
summ1
    files :: [FilePath]
files = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"checkDup" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModLocation -> Maybe FilePath
ml_hs_file forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location) [ModSummary]
summs

keepGoingPruneErr :: [NodeKey] -> SDoc
keepGoingPruneErr :: [NodeKey] -> SDoc
keepGoingPruneErr [NodeKey]
ms
  = [SDoc] -> SDoc
vcat (( FilePath -> SDoc
text FilePath
"-fkeep-going in use, removing the following" SDoc -> SDoc -> SDoc
<+>
            FilePath -> SDoc
text FilePath
"dependencies and continuing:")forall a. a -> [a] -> [a]
:
          forall a b. (a -> b) -> [a] -> [b]
map (Int -> SDoc -> SDoc
nest Int
6 forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> SDoc
pprNodeKey) [NodeKey]
ms )

cyclicModuleErr :: [ModuleGraphNode] -> SDoc
-- From a strongly connected component we find
-- a single cycle to report
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss
  = ASSERT( not (null mss) )
    case forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node NodeKey ModuleGraphNode]
graph of
       Maybe [ModuleGraphNode]
Nothing   -> FilePath -> SDoc
text FilePath
"Unexpected non-cycle" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mss
       Just [ModuleGraphNode]
path0 -> [SDoc] -> SDoc
vcat
        [ case [ModuleGraphNode] -> ([InstantiatedUnit], [ExtendedModSummary])
partitionNodes [ModuleGraphNode]
path0 of
            ([],[ExtendedModSummary]
_) -> FilePath -> SDoc
text FilePath
"Module imports form a cycle:"
            ([InstantiatedUnit]
_,[]) -> FilePath -> SDoc
text FilePath
"Module instantiations form a cycle:"
            ([InstantiatedUnit], [ExtendedModSummary])
_ -> FilePath -> SDoc
text FilePath
"Module imports and instantiations form a cycle:"
        , Int -> SDoc -> SDoc
nest Int
2 ([ModuleGraphNode] -> SDoc
show_path [ModuleGraphNode]
path0)]
  where
    graph :: [Node NodeKey ModuleGraphNode]
    graph :: [Node NodeKey ModuleGraphNode]
graph =
      [ DigraphNode
        { node_payload :: ModuleGraphNode
node_payload = ModuleGraphNode
ms
        , node_key :: NodeKey
node_key = ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
ms
        , node_dependencies :: [NodeKey]
node_dependencies = ModuleGraphNode -> [NodeKey]
get_deps ModuleGraphNode
ms
        }
      | ModuleGraphNode
ms <- [ModuleGraphNode]
mss
      ]

    get_deps :: ModuleGraphNode -> [NodeKey]
    get_deps :: ModuleGraphNode -> [NodeKey]
get_deps = \case
      InstantiationNode InstantiatedUnit
iuid ->
        [ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = ModuleName
hole, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
        | ModuleName
hole <- forall a. UniqDSet a -> [a]
uniqDSetToList forall a b. (a -> b) -> a -> b
$ forall unit. GenInstantiatedUnit unit -> UniqDSet ModuleName
instUnitHoles InstantiatedUnit
iuid
        ]
      ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bds) ->
        [ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
IsBoot }
        | GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
ms ] forall a. [a] -> [a] -> [a]
++
        [ ModNodeKey -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ GWIB { gwib_mod :: ModuleName
gwib_mod = forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
m, gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot }
        | GenLocated SrcSpan ModuleName
m <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_imps    ModSummary
ms ] forall a. [a] -> [a] -> [a]
++
        [ InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
inst_unit
        | InstantiatedUnit
inst_unit <- [InstantiatedUnit]
bds
        ]

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

    ppr_node :: ModuleGraphNode -> SDoc
    ppr_node :: ModuleGraphNode -> SDoc
ppr_node (ModuleNode ExtendedModSummary
m) = FilePath -> SDoc
text FilePath
"module" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms (ExtendedModSummary -> ModSummary
emsModSummary ExtendedModSummary
m)
    ppr_node (InstantiationNode InstantiatedUnit
u) = FilePath -> SDoc
text FilePath
"instantiated unit" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
u

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