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

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

        downsweep,

        topSortModuleGraph,

        ms_home_srcimps, ms_home_imps,

        IsBoot(..),
        summariseModule,
        hscSourceToIsBoot,
        findExtraSigImports,
        implicitRequirements,

        noModError, cyclicModuleErr,
        moduleGraphNodes, SummaryNode
    ) where

#include "HsVersions.h"

import GhcPrelude

import qualified Linker         ( unload )

import DriverPhases
import DriverPipeline
import DynFlags
import ErrUtils
import Finder
import GhcMonad
import HeaderInfo
import HscTypes
import Module
import TcIface          ( typecheckIface )
import TcRnMonad        ( initIfaceCheck )
import HscMain

import Bag              ( unitBag, listToBag, unionManyBags, isEmptyBag )
import BasicTypes
import Digraph
import Exception        ( tryIO, gbracket, gfinally )
import FastString
import Maybes           ( expectJust )
import Name
import MonadUtils       ( allM, MonadIO )
import Outputable
import Panic
import SrcLoc
import StringBuffer
import UniqFM
import UniqDSet
import TcBackpack
import Packages
import UniqSet
import Util
import qualified GHC.LanguageExtensions as LangExt
import NameEnv
import FileCleanup

import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import qualified 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 Data.IORef
import Data.List
import qualified Data.List as List
import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
import System.Directory
import System.FilePath
import System.IO        ( fixIO )
import System.IO.Error  ( isDoesNotExistError )

import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )

label_self :: String -> IO ()
label_self :: String -> IO ()
label_self String
thread_name = do
    ThreadId
self_tid <- IO ThreadId
CC.myThreadId
    ThreadId -> String -> IO ()
CC.labelThread ThreadId
self_tid String
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.
--
depanal :: GhcMonad m =>
           [ModuleName]  -- ^ excluded modules
        -> Bool          -- ^ allow duplicate roots
        -> m ModuleGraph
depanal :: [ModuleName] -> Bool -> m ModuleGraph
depanal [ModuleName]
excluded_mods Bool
allow_dup_roots = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    (ErrorMessages
errs, ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
    if ErrorMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
      then do
        HscEnv -> ModuleGraph -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph
        HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
        ModuleGraph -> m ModuleGraph
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraph
mod_graph
      else ErrorMessages -> m ModuleGraph
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
errs


-- | 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 :: [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots = do
  HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  let
         dflags :: DynFlags
dflags  = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
         targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
         old_graph :: ModuleGraph
old_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env

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

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

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

-- Note [Missing home modules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
-- in a command line. For example, cabal may want to enable this warning
-- when building a library, so that GHC warns user about modules, not listed
-- neither in `exposed-modules`, nor in `other-modules`.
--
-- Here "home module" means a module, that doesn't come from an other package.
--
-- For example, if GHC is invoked with modules "A" and "B" as targets,
-- but "A" imports some other module "C", then GHC will issue a warning
-- about module "C" not being listed in a command line.
--
-- The warning in enabled by `-Wmissing-home-modules`. See #13129
warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules :: HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingHomeModules DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag [ErrMsg
warn])
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    targets :: [TargetId]
targets = (Target -> TargetId) -> [Target] -> [TargetId]
forall a b. (a -> b) -> [a] -> [b]
map Target -> TargetId
targetId (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env)

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

    -- We need to be careful to handle the case where (possibly
    -- path-qualified) filenames (aka 'TargetFile') rather than module
    -- names are being passed on the GHC command-line.
    --
    -- For instance, `ghc --make src-exe/Main.hs` and
    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.
    -- Note also that we can't always infer the associated module name
    -- directly from the filename argument.  See #13727.
    is_my_target :: ModSummary -> TargetId -> Bool
is_my_target ModSummary
mod (TargetModule ModuleName
name)
      = Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
name
    is_my_target ModSummary
mod (TargetFile String
target_file Maybe Phase
_)
      | Just String
mod_file <- ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod)
      = String
target_file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mod_file Bool -> Bool -> Bool
||

           --  Don't warn on B.hs-boot if B.hs is specified (#16551)
           String -> String
addBootSuffix String
target_file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
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
           String -> ModuleName
mkModuleName ((String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ String -> (String, String)
splitExtension String
target_file)
            ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod)
    is_my_target ModSummary
_ TargetId
_ = Bool
False

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

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

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

-- | Try to load the program.  See 'LoadHowMuch' for the different modes.
--
-- This function implements the core of GHC's @--make@ mode.  It preprocesses,
-- compiles and loads the specified modules, avoiding re-compilation wherever
-- possible.  Depending on the target (see 'DynFlags.hscTarget') compiling
-- and loading may result in files being created on disk.
--
-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
-- successful or not.
--
-- Throw a 'SourceError' if errors are encountered before the actual
-- compilation starts (e.g., during dependency analysis).  All other errors
-- are reported using the 'defaultWarnErrLogger'.
--
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load :: LoadHowMuch -> m SuccessFlag
load LoadHowMuch
how_much = do
    ModuleGraph
mod_graph <- [ModuleName] -> Bool -> m ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
False
    SuccessFlag
success <- LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
batchMsg) ModuleGraph
mod_graph
    m ()
forall (m :: * -> *). GhcMonad m => m ()
warnUnusedPackages
    SuccessFlag -> m SuccessFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success

-- 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 :: GhcMonad m => m ()
warnUnusedPackages :: m ()
warnUnusedPackages = do
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    ExternalPackageState
eps <- IO ExternalPackageState -> m ExternalPackageState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> m ExternalPackageState)
-> IO ExternalPackageState -> m ExternalPackageState
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env

    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        pit :: PackageIfaceTable
pit = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps

    let loadedPackages :: [PackageConfig]
loadedPackages
          = (UnitId -> PackageConfig) -> [UnitId] -> [PackageConfig]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> UnitId -> PackageConfig
getPackageDetails DynFlags
dflags)
          ([UnitId] -> [PackageConfig])
-> (PackageIfaceTable -> [UnitId])
-> PackageIfaceTable
-> [PackageConfig]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> [UnitId]
forall a. Eq a => [a] -> [a]
nub ([UnitId] -> [UnitId])
-> (PackageIfaceTable -> [UnitId]) -> PackageIfaceTable -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
sort
          ([UnitId] -> [UnitId])
-> (PackageIfaceTable -> [UnitId]) -> PackageIfaceTable -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> UnitId) -> [Module] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Module -> UnitId
moduleUnitId
          ([Module] -> [UnitId])
-> (PackageIfaceTable -> [Module]) -> PackageIfaceTable -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIfaceTable -> [Module]
forall a. ModuleEnv a -> [Module]
moduleEnvKeys
          (PackageIfaceTable -> [PackageConfig])
-> PackageIfaceTable -> [PackageConfig]
forall a b. (a -> b) -> a -> b
$ PackageIfaceTable
pit

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

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

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

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedPackages DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([PackageArg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageArg]
unusedArgs)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag [ErrMsg
warn])

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

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

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

        matchingStr :: String -> PackageConfig -> Bool
        matchingStr :: String -> PackageConfig -> Bool
matchingStr String
str PackageConfig
p
                =  String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> String
sourcePackageIdString PackageConfig
p
                Bool -> Bool -> Bool
|| String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== PackageConfig -> String
packageNameString PackageConfig
p

        matching :: DynFlags -> PackageArg -> PackageConfig -> Bool
        matching :: DynFlags -> PackageArg -> PackageConfig -> Bool
matching DynFlags
_ (PackageArg String
str) PackageConfig
p = String -> PackageConfig -> Bool
matchingStr String
str PackageConfig
p
        matching DynFlags
dflags (UnitIdArg UnitId
uid) PackageConfig
p = UnitId
uid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> PackageConfig -> UnitId
realUnitId DynFlags
dflags PackageConfig
p

        -- For wired-in packages, we have to unwire their id,
        -- otherwise they won't match package flags
        realUnitId :: DynFlags -> PackageConfig -> UnitId
        realUnitId :: DynFlags -> PackageConfig -> UnitId
realUnitId DynFlags
dflags
          = DynFlags -> UnitId -> UnitId
unwireUnitId DynFlags
dflags
          (UnitId -> UnitId)
-> (PackageConfig -> UnitId) -> PackageConfig -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefUnitId -> UnitId
DefiniteUnitId
          (DefUnitId -> UnitId)
-> (PackageConfig -> DefUnitId) -> PackageConfig -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledUnitId -> DefUnitId
DefUnitId
          (InstalledUnitId -> DefUnitId)
-> (PackageConfig -> InstalledUnitId) -> PackageConfig -> DefUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageConfig -> InstalledUnitId
installedPackageConfigId

-- | 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' :: LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
    (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
    m ()
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
    HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

    let hpt1 :: HomePackageTable
hpt1   = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    if SuccessFlag -> Bool
succeeded SuccessFlag
upsweep_ok

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

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

          -- Issue a warning for the confusing case where the user
          -- said '-o foo' but we're not going to do any linking.
          -- We attempt linking if either (a) one of the modules is
          -- called Main, or (b) the user said -no-hs-main, indicating
          -- that main() is going to come from somewhere else.
          --
          let ofile :: Maybe String
ofile = DynFlags -> Maybe String
outputFile DynFlags
dflags
          let no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
          let
            main_mod :: Module
main_mod = DynFlags -> Module
mainModIs DynFlags
dflags
            a_root_is_Main :: Bool
a_root_is_Main = ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph
mod_graph Module
main_mod
            do_linking :: Bool
do_linking = Bool
a_root_is_Main Bool -> Bool -> Bool
|| Bool
no_hs_main Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib

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

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

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

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

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

          -- Clean up after ourselves

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

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

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


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

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

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


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

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

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

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

-- -----------------------------------------------------------------------------
--
-- | Prune the HomePackageTable
--
-- Before doing an upsweep, we can throw away:
--
--   - For non-stable modules:
--      - all ModDetails, all linked code
--   - all unlinked code that is out of date with respect to
--     the source file
--
-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
-- space at the end of the upsweep, because the topmost ModDetails of the
-- old HPT holds on to the entire type environment from the previous
-- compilation.
pruneHomePackageTable :: HomePackageTable
                      -> [ModSummary]
                      -> StableModules
                      -> HomePackageTable
pruneHomePackageTable :: HomePackageTable
-> [ModSummary]
-> (UniqSet ModuleName, UniqSet ModuleName)
-> HomePackageTable
pruneHomePackageTable HomePackageTable
hpt [ModSummary]
summ (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco)
  = (HomeModInfo -> HomeModInfo)
-> HomePackageTable -> HomePackageTable
mapHpt HomeModInfo -> HomeModInfo
prune HomePackageTable
hpt
  where prune :: HomeModInfo -> HomeModInfo
prune HomeModInfo
hmi
          | ModuleName -> Bool
is_stable ModuleName
modl = HomeModInfo
hmi'
          | Bool
otherwise      = HomeModInfo
hmi'{ hm_details :: ModDetails
hm_details = ModDetails
emptyModDetails }
          where
           modl :: ModuleName
modl = Module -> ModuleName
moduleName (ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hmi))
           hmi' :: HomeModInfo
hmi' | Just Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi, Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< ModSummary -> UTCTime
ms_hs_date ModSummary
ms
                = HomeModInfo
hmi{ hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
forall a. Maybe a
Nothing }
                | Bool
otherwise
                = HomeModInfo
hmi
                where ms :: ModSummary
ms = String -> Maybe ModSummary -> ModSummary
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"prune" (UniqFM ModSummary -> ModuleName -> Maybe ModSummary
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM ModSummary
ms_map ModuleName
modl)

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

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

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


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

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

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

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

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

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

@
  stable m = stableObject m || stableBCO m

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

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

  These properties embody the following ideas:

    - if a module is stable, then:

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

-- A Module and whether it is a boot module.
type BuildModule = (Module, IsBoot)

-- | 'Bool' indicating if a module is a boot module or not.  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 IsBoot = IsBoot | NotBoot
    deriving (Eq IsBoot
Eq IsBoot
-> (IsBoot -> IsBoot -> Ordering)
-> (IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> IsBoot)
-> (IsBoot -> IsBoot -> IsBoot)
-> Ord IsBoot
IsBoot -> IsBoot -> Bool
IsBoot -> IsBoot -> Ordering
IsBoot -> IsBoot -> IsBoot
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 :: IsBoot -> IsBoot -> IsBoot
$cmin :: IsBoot -> IsBoot -> IsBoot
max :: IsBoot -> IsBoot -> IsBoot
$cmax :: IsBoot -> IsBoot -> IsBoot
>= :: IsBoot -> IsBoot -> Bool
$c>= :: IsBoot -> IsBoot -> Bool
> :: IsBoot -> IsBoot -> Bool
$c> :: IsBoot -> IsBoot -> Bool
<= :: IsBoot -> IsBoot -> Bool
$c<= :: IsBoot -> IsBoot -> Bool
< :: IsBoot -> IsBoot -> Bool
$c< :: IsBoot -> IsBoot -> Bool
compare :: IsBoot -> IsBoot -> Ordering
$ccompare :: IsBoot -> IsBoot -> Ordering
$cp1Ord :: Eq IsBoot
Ord, IsBoot -> IsBoot -> Bool
(IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> Bool) -> Eq IsBoot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsBoot -> IsBoot -> Bool
$c/= :: IsBoot -> IsBoot -> Bool
== :: IsBoot -> IsBoot -> Bool
$c== :: IsBoot -> IsBoot -> Bool
Eq, Int -> IsBoot -> String -> String
[IsBoot] -> String -> String
IsBoot -> String
(Int -> IsBoot -> String -> String)
-> (IsBoot -> String)
-> ([IsBoot] -> String -> String)
-> Show IsBoot
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [IsBoot] -> String -> String
$cshowList :: [IsBoot] -> String -> String
show :: IsBoot -> String
$cshow :: IsBoot -> String
showsPrec :: Int -> IsBoot -> String -> String
$cshowsPrec :: Int -> IsBoot -> String -> String
Show, ReadPrec [IsBoot]
ReadPrec IsBoot
Int -> ReadS IsBoot
ReadS [IsBoot]
(Int -> ReadS IsBoot)
-> ReadS [IsBoot]
-> ReadPrec IsBoot
-> ReadPrec [IsBoot]
-> Read IsBoot
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IsBoot]
$creadListPrec :: ReadPrec [IsBoot]
readPrec :: ReadPrec IsBoot
$creadPrec :: ReadPrec IsBoot
readList :: ReadS [IsBoot]
$creadList :: ReadS [IsBoot]
readsPrec :: Int -> ReadS IsBoot
$creadsPrec :: Int -> ReadS IsBoot
Read)

-- | Tests if an 'HscSource' is a boot file, primarily for constructing
-- elements of 'BuildModule'.
hscSourceToIsBoot :: HscSource -> IsBoot
hscSourceToIsBoot :: HscSource -> IsBoot
hscSourceToIsBoot HscSource
HsBootFile = IsBoot
IsBoot
hscSourceToIsBoot HscSource
_ = IsBoot
NotBoot

mkBuildModule :: ModSummary -> BuildModule
mkBuildModule :: ModSummary -> BuildModule
mkBuildModule ModSummary
ms = (ModSummary -> Module
ms_mod ModSummary
ms, if ModSummary -> Bool
isBootSummary ModSummary
ms then IsBoot
IsBoot else IsBoot
NotBoot)

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

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

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

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

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

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


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

    m Int
-> (Int -> m ())
-> (Int -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket m Int
updNumCapabilities Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
resetNumCapabilities ((Int -> m (SuccessFlag, [ModSummary]))
 -> m (SuccessFlag, [ModSummary]))
-> (Int -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary])
forall a b. (a -> b) -> a -> b
$ \Int
_ -> do

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

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

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

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

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


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

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

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

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

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

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

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


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


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

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

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

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

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

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

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

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

    let home_imps :: [ModuleName]
home_imps     = (Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([Located ModuleName] -> [ModuleName])
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [Located ModuleName]
ms_home_imps ModSummary
mod
    let home_src_imps :: [ModuleName]
home_src_imps = (Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([Located ModuleName] -> [ModuleName])
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
mod

    -- All the textual imports of this module.
    let textual_deps :: Set BuildModule
textual_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList ([BuildModule] -> Set BuildModule)
-> [BuildModule] -> Set BuildModule
forall a b. (a -> b) -> a -> b
$ (ModuleName -> Module) -> [(ModuleName, IsBoot)] -> [BuildModule]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst (UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
lcl_dflags)) ([(ModuleName, IsBoot)] -> [BuildModule])
-> [(ModuleName, IsBoot)] -> [BuildModule]
forall a b. (a -> b) -> a -> b
$
                            [ModuleName] -> [IsBoot] -> [(ModuleName, IsBoot)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
home_imps     (IsBoot -> [IsBoot]
forall a. a -> [a]
repeat IsBoot
NotBoot) [(ModuleName, IsBoot)]
-> [(ModuleName, IsBoot)] -> [(ModuleName, IsBoot)]
forall a. [a] -> [a] -> [a]
++
                            [ModuleName] -> [IsBoot] -> [(ModuleName, IsBoot)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
home_src_imps (IsBoot -> [IsBoot]
forall a. a -> [a]
repeat IsBoot
IsBoot)

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


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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

unitIdsToCheck :: DynFlags -> [UnitId]
unitIdsToCheck :: DynFlags -> [UnitId]
unitIdsToCheck DynFlags
dflags =
  [UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
nubSort ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ (UnitId -> [UnitId]) -> [UnitId] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitId -> [UnitId]
goUnitId (PackageState -> [UnitId]
explicitPackages (DynFlags -> PackageState
pkgState DynFlags
dflags))
 where
  goUnitId :: UnitId -> [UnitId]
goUnitId UnitId
uid =
    case UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts UnitId
uid of
      (InstalledUnitId
_, Just IndefUnitId
indef) ->
        let insts :: [(ModuleName, Module)]
insts = IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef
        in UnitId
uid UnitId -> [UnitId] -> [UnitId]
forall a. a -> [a] -> [a]
: ((ModuleName, Module) -> [UnitId])
-> [(ModuleName, Module)] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (UnitId -> [UnitId]
goUnitId (UnitId -> [UnitId])
-> ((ModuleName, Module) -> UnitId)
-> (ModuleName, Module)
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> UnitId
moduleUnitId (Module -> UnitId)
-> ((ModuleName, Module) -> Module)
-> (ModuleName, Module)
-> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Module) -> Module
forall a b. (a, b) -> b
snd) [(ModuleName, Module)]
insts
      (InstalledUnitId, Maybe IndefUnitId)
_ -> []

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.
    = String -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> String
ml_hi_file ModLocation
location)
 | Bool
otherwise
    = Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing

-- | Compile a single module.  Always produce a Linkable for it if
-- successful.  If no compilation happened, return the old Linkable.
upsweep_mod :: HscEnv
            -> Maybe Messager
            -> HomePackageTable
            -> StableModules
            -> ModSummary
            -> Int  -- index of module
            -> Int  -- total number of modules
            -> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco) ModSummary
summary Int
mod_index Int
nmods
   =    let
            this_mod_name :: ModuleName
this_mod_name = ModSummary -> ModuleName
ms_mod_name ModSummary
summary
            this_mod :: Module
this_mod    = ModSummary -> Module
ms_mod ModSummary
summary
            mb_obj_date :: Maybe UTCTime
mb_obj_date = ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
summary
            mb_if_date :: Maybe UTCTime
mb_if_date  = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
summary
            obj_fn :: String
obj_fn      = ModLocation -> String
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
            hs_date :: UTCTime
hs_date     = ModSummary -> UTCTime
ms_hs_date ModSummary
summary

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    initial_graph :: Graph (Node Int ModSummary)
initial_graph = case Maybe ModuleName
mb_root_mod of
        Maybe ModuleName
Nothing -> Graph (Node Int ModSummary)
graph
        Just ModuleName
root_mod ->
            -- restrict the graph to just those modules reachable from
            -- the specified module.  We do this by building a graph with
            -- the full set of nodes, and determining the reachable set from
            -- the specified node.
            let root :: Node Int ModSummary
root | Just Node Int ModSummary
node <- HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node HscSource
HsSrcFile ModuleName
root_mod
                     , Graph (Node Int ModSummary)
graph Graph (Node Int ModSummary) -> Node Int ModSummary -> Bool
forall node. Graph node -> node -> Bool
`hasVertexG` Node Int ModSummary
node
                     = Node Int ModSummary
node
                     | Bool
otherwise
                     = GhcException -> Node Int ModSummary
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError String
"module does not exist")
            in [Node Int ModSummary] -> Graph (Node Int ModSummary)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (Node Int ModSummary
-> [Node Int ModSummary] -> [Node Int ModSummary]
seq Node Int ModSummary
root (Graph (Node Int ModSummary)
-> Node Int ModSummary -> [Node Int ModSummary]
forall node. Graph node -> node -> [node]
reachableG Graph (Node Int ModSummary)
graph Node Int ModSummary
root))

type SummaryNode = Node Int ModSummary

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

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

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

    lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
    lookup_node :: HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node HscSource
hs_src ModuleName
mod = (ModuleName, IsBoot)
-> Map (ModuleName, IsBoot) (Node Int ModSummary)
-> Maybe (Node Int ModSummary)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModuleName
mod, HscSource -> IsBoot
hscSourceToIsBoot HscSource
hs_src) Map (ModuleName, IsBoot) (Node Int ModSummary)
node_map

    lookup_key :: HscSource -> ModuleName -> Maybe Int
    lookup_key :: HscSource -> ModuleName -> Maybe Int
lookup_key HscSource
hs_src ModuleName
mod = (Node Int ModSummary -> Int)
-> Maybe (Node Int ModSummary) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node Int ModSummary -> Int
summaryNodeKey (HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node HscSource
hs_src ModuleName
mod)

    node_map :: NodeMap SummaryNode
    node_map :: Map (ModuleName, IsBoot) (Node Int ModSummary)
node_map = [((ModuleName, IsBoot), Node Int ModSummary)]
-> Map (ModuleName, IsBoot) (Node Int ModSummary)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ((Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
s),
                                HscSource -> IsBoot
hscSourceToIsBoot (ModSummary -> HscSource
ms_hsc_src ModSummary
s)), Node Int ModSummary
node)
                            | Node Int ModSummary
node <- [Node Int ModSummary]
nodes
                            , let s :: ModSummary
s = Node Int ModSummary -> ModSummary
summaryNodeSummary Node Int ModSummary
node ]

    -- We use integers as the keys for the SCC algorithm
    nodes :: [SummaryNode]
    nodes :: [Node Int ModSummary]
nodes = [ ModSummary -> Int -> [Int] -> Node Int ModSummary
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ModSummary
s Int
key [Int]
out_keys
            | (ModSummary
s, Int
key) <- [(ModSummary, Int)]
numbered_summaries
             -- Drop the hi-boot ones if told to do so
            , Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
s Bool -> Bool -> Bool
&& Bool
drop_hs_boot_nodes)
            , let out_keys :: [Int]
out_keys = HscSource -> [ModuleName] -> [Int]
out_edge_keys HscSource
hs_boot_key ((Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
s)) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
                             HscSource -> [ModuleName] -> [Int]
out_edge_keys HscSource
HsSrcFile   ((Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ModSummary -> [Located ModuleName]
ms_home_imps ModSummary
s)) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
                             (-- see [boot-edges] below
                              if Bool
drop_hs_boot_nodes Bool -> Bool -> Bool
|| ModSummary -> HscSource
ms_hsc_src ModSummary
s HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
                              then []
                              else case HscSource -> ModuleName -> Maybe Int
lookup_key HscSource
HsBootFile (ModSummary -> ModuleName
ms_mod_name ModSummary
s) of
                                    Maybe Int
Nothing -> []
                                    Just Int
k  -> [Int
k]) ]

    -- [boot-edges] if this is a .hs and there is an equivalent
    -- .hs-boot, add a link from the former to the latter.  This
    -- has the effect of detecting bogus cases where the .hs-boot
    -- depends on the .hs, by introducing a cycle.  Additionally,
    -- it ensures that we will always process the .hs-boot before
    -- the .hs, and so the HomePackageTable will always have the
    -- most up to date information.

    -- Drop hs-boot nodes by using HsSrcFile as the key
    hs_boot_key :: HscSource
hs_boot_key | Bool
drop_hs_boot_nodes = HscSource
HsSrcFile
                | Bool
otherwise          = HscSource
HsBootFile

    out_edge_keys :: HscSource -> [ModuleName] -> [Int]
    out_edge_keys :: HscSource -> [ModuleName] -> [Int]
out_edge_keys HscSource
hi_boot [ModuleName]
ms = (ModuleName -> Maybe Int) -> [ModuleName] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (HscSource -> ModuleName -> Maybe Int
lookup_key HscSource
hi_boot) [ModuleName]
ms
        -- If we want keep_hi_boot_nodes, then we do lookup_key with
        -- IsBoot; else NotBoot

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

msKey :: ModSummary -> NodeKey
msKey :: ModSummary -> (ModuleName, IsBoot)
msKey (ModSummary { ms_mod :: ModSummary -> Module
ms_mod = Module
mod, ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
boot })
    = (Module -> ModuleName
moduleName Module
mod, HscSource -> IsBoot
hscSourceToIsBoot HscSource
boot)

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

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

-- | If there are {-# SOURCE #-} imports between strongly connected
-- components in the topological sort, then those imports can
-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
-- were necessary, then the edge would be part of a cycle.
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports :: [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
sccs = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedImports DynFlags
dflags)
    (ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag ((SCC ModSummary -> [ErrMsg]) -> [SCC ModSummary] -> [ErrMsg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags -> [ModSummary] -> [ErrMsg]
check DynFlags
dflags ([ModSummary] -> [ErrMsg])
-> (SCC ModSummary -> [ModSummary]) -> SCC ModSummary -> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs)))
  where check :: DynFlags -> [ModSummary] -> [ErrMsg]
check DynFlags
dflags [ModSummary]
ms =
           let mods_in_this_cycle :: [ModuleName]
mods_in_this_cycle = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
ms in
           [ DynFlags -> Located ModuleName -> ErrMsg
warn DynFlags
dflags Located ModuleName
i | ModSummary
m <- [ModSummary]
ms, Located ModuleName
i <- ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
m,
                             Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
i ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`  [ModuleName]
mods_in_this_cycle ]

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


reportImportErrors :: MonadIO m => [Either ErrorMessages b] -> m [b]
reportImportErrors :: [Either ErrorMessages b] -> m [b]
reportImportErrors [Either ErrorMessages b]
xs | [ErrorMessages] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMessages]
errs = [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b]
oks
                      | Bool
otherwise = ErrorMessages -> m [b]
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors (ErrorMessages -> m [b]) -> ErrorMessages -> m [b]
forall a b. (a -> b) -> a -> b
$ [ErrorMessages] -> ErrorMessages
forall a. [Bag a] -> Bag a
unionManyBags [ErrorMessages]
errs
  where ([ErrorMessages]
errs, [b]
oks) = [Either ErrorMessages b] -> ([ErrorMessages], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages b]
xs


-----------------------------------------------------------------------------
--
-- | Downsweep (dependency analysis)
--
-- Chase downwards from the specified root set, returning summaries
-- for all home modules encountered.  Only follow source-import
-- links.
--
-- We pass in the previous collection of summaries, which is used as a
-- cache to avoid recalculating a module summary if the source is
-- unchanged.
--
-- The returned list of [ModSummary] nodes has one node for each home-package
-- module, plus one for any hs-boot files.  The imports of these nodes
-- are all there, including the imports of non-home-package modules.
downsweep :: HscEnv
          -> [ModSummary]       -- Old summaries
          -> [ModuleName]       -- Ignore dependencies on these; treat
                                -- them as if they were package modules
          -> Bool               -- True <=> allow multiple targets to have
                                --          the same module name; this is
                                --          very useful for ghc -M
          -> IO [Either ErrorMessages ModSummary]
                -- The elts of [ModSummary] all have distinct
                -- (Modules, IsBoot) identifiers, unless the Bool is true
                -- in which case there can be repeats
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ModSummary]
downsweep HscEnv
hsc_env [ModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots
   = do
       [Either ErrorMessages ModSummary]
rootSummaries <- (Target -> IO (Either ErrorMessages ModSummary))
-> [Target] -> IO [Either ErrorMessages ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Target -> IO (Either ErrorMessages ModSummary)
getRootSummary [Target]
roots
       [ModSummary]
rootSummariesOk <- [Either ErrorMessages ModSummary] -> IO [ModSummary]
forall (m :: * -> *) b.
MonadIO m =>
[Either ErrorMessages b] -> m [b]
reportImportErrors [Either ErrorMessages ModSummary]
rootSummaries
       let root_map :: NodeMap [Either ErrorMessages ModSummary]
root_map = [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap [ModSummary]
rootSummariesOk
       NodeMap [Either ErrorMessages ModSummary] -> IO ()
checkDuplicates NodeMap [Either ErrorMessages ModSummary]
root_map
       NodeMap [Either ErrorMessages ModSummary]
map0 <- [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop ((ModSummary -> [(Located ModuleName, IsBoot)])
-> [ModSummary] -> [(Located ModuleName, IsBoot)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [(Located ModuleName, IsBoot)]
calcDeps [ModSummary]
rootSummariesOk) NodeMap [Either ErrorMessages ModSummary]
root_map
       -- if we have been passed -fno-code, we enable code generation
       -- for dependencies of modules that have -XTemplateHaskell,
       -- otherwise those modules will fail to compile.
       -- See Note [-fno-code mode] #8025
       NodeMap [Either ErrorMessages ModSummary]
map1 <- if DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing
         then HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH
           (DynFlags -> HscTarget
defaultObjectTarget DynFlags
dflags)
           NodeMap [Either ErrorMessages ModSummary]
map0
         else if DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted
           then HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuplesOrSums
             (DynFlags -> HscTarget
defaultObjectTarget DynFlags
dflags)
             NodeMap [Either ErrorMessages ModSummary]
map0
           else NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
map0
       [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either ErrorMessages ModSummary]
 -> IO [Either ErrorMessages ModSummary])
-> [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ [[Either ErrorMessages ModSummary]]
-> [Either ErrorMessages ModSummary]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either ErrorMessages ModSummary]]
 -> [Either ErrorMessages ModSummary])
-> [[Either ErrorMessages ModSummary]]
-> [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ NodeMap [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall a. NodeMap a -> [a]
nodeMapElts NodeMap [Either ErrorMessages ModSummary]
map1
     where
        calcDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
calcDeps = ModSummary -> [(Located ModuleName, IsBoot)]
msDeps

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

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

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

        rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
fsLit String
"<command line>")

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

        loop :: [(Located ModuleName,IsBoot)]
                        -- Work list: process these modules
             -> NodeMap [Either ErrorMessages ModSummary]
                        -- Visited set; the range is a list because
                        -- the roots can have the same module names
                        -- if allow_dup_roots is True
             -> IO (NodeMap [Either ErrorMessages ModSummary])
                        -- The result is the completed NodeMap
        loop :: [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [] NodeMap [Either ErrorMessages ModSummary]
done = NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
done
        loop ((Located ModuleName
wanted_mod, IsBoot
is_boot) : [(Located ModuleName, IsBoot)]
ss) NodeMap [Either ErrorMessages ModSummary]
done
          | Just [Either ErrorMessages ModSummary]
summs <- (ModuleName, IsBoot)
-> NodeMap [Either ErrorMessages ModSummary]
-> Maybe [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModuleName, IsBoot)
key NodeMap [Either ErrorMessages ModSummary]
done
          = if [Either ErrorMessages ModSummary] -> Bool
forall a. [a] -> Bool
isSingleton [Either ErrorMessages ModSummary]
summs then
                [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [(Located ModuleName, IsBoot)]
ss NodeMap [Either ErrorMessages ModSummary]
done
            else
                do { DynFlags -> [ModSummary] -> IO ()
multiRootsErr DynFlags
dflags ([Either ErrorMessages ModSummary] -> [ModSummary]
forall a b. [Either a b] -> [b]
rights [Either ErrorMessages ModSummary]
summs); NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
forall k a. Map k a
Map.empty }
          | Bool
otherwise
          = do Maybe (Either ErrorMessages ModSummary)
mb_s <- HscEnv
-> NodeMap ModSummary
-> IsBoot
-> Located ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule HscEnv
hsc_env NodeMap ModSummary
old_summary_map
                                       IsBoot
is_boot Located ModuleName
wanted_mod Bool
True
                                       Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing [ModuleName]
excl_mods
               case Maybe (Either ErrorMessages ModSummary)
mb_s of
                   Maybe (Either ErrorMessages ModSummary)
Nothing -> [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [(Located ModuleName, IsBoot)]
ss NodeMap [Either ErrorMessages ModSummary]
done
                   Just (Left ErrorMessages
e) -> [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [(Located ModuleName, IsBoot)]
ss ((ModuleName, IsBoot)
-> [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ModuleName, IsBoot)
key [ErrorMessages -> Either ErrorMessages ModSummary
forall a b. a -> Either a b
Left ErrorMessages
e] NodeMap [Either ErrorMessages ModSummary]
done)
                   Just (Right ModSummary
s)-> do
                     NodeMap [Either ErrorMessages ModSummary]
new_map <-
                       [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop (ModSummary -> [(Located ModuleName, IsBoot)]
calcDeps ModSummary
s) ((ModuleName, IsBoot)
-> [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ModuleName, IsBoot)
key [ModSummary -> Either ErrorMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s] NodeMap [Either ErrorMessages ModSummary]
done)
                     [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [(Located ModuleName, IsBoot)]
ss NodeMap [Either ErrorMessages ModSummary]
new_map
          where
            key :: (ModuleName, IsBoot)
key = (Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
wanted_mod, IsBoot
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 :: HscTarget
  -> NodeMap [Either ErrorMessages ModSummary]
  -> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH :: HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH =
  (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen 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 -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing Bool -> Bool -> Bool
&&
      -- Don't enable codegen for TH on indefinite packages; we
      -- can't compile anything anyway! See #16219.
      Bool -> Bool
not (DynFlags -> Bool
isIndefinite DynFlags
dflags)

-- | Update the every ModSummary that is depended on
-- by a module that needs unboxed tuples. We enable codegen to
-- the specified target, disable optimization and change the .hi
-- and .o file locations to be temporary files.
--
-- This is used used in order to load code that uses unboxed tuples
-- or sums into GHCi while still allowing some code to be interpreted.
enableCodeGenForUnboxedTuplesOrSums :: HscTarget
  -> NodeMap [Either ErrorMessages ModSummary]
  -> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuplesOrSums :: HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuplesOrSums =
  (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
TFL_GhcSession TempFileLifetime
TFL_CurrentModule
  where
    condition :: ModSummary -> Bool
condition ModSummary
ms =
      DynFlags -> Bool
unboxed_tuples_or_sums (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) Bool -> Bool -> Bool
&&
      Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ByteCode (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)) Bool -> Bool -> Bool
&&
      Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
ms)
    unboxed_tuples_or_sums :: DynFlags -> Bool
unboxed_tuples_or_sums DynFlags
d =
      Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnboxedTuples DynFlags
d Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnboxedSums DynFlags
d
    should_modify :: ModSummary -> Bool
should_modify (ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
      DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted

-- | Helper used to implement 'enableCodeGenForTH' and
-- 'enableCodeGenForUnboxedTuples'. 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
  :: (ModSummary -> Bool)
  -> (ModSummary -> Bool)
  -> TempFileLifetime
  -> TempFileLifetime
  -> HscTarget
  -> NodeMap [Either ErrorMessages ModSummary]
  -> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen :: (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
staticLife TempFileLifetime
dynLife HscTarget
target NodeMap [Either ErrorMessages ModSummary]
nodemap =
  ([Either ErrorMessages ModSummary]
 -> IO [Either ErrorMessages ModSummary])
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either ErrorMessages ModSummary
 -> IO (Either ErrorMessages ModSummary))
-> [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ModSummary -> IO ModSummary)
-> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ModSummary -> IO ModSummary
enable_code_gen)) NodeMap [Either ErrorMessages ModSummary]
nodemap
  where
    enable_code_gen :: ModSummary -> IO ModSummary
enable_code_gen ModSummary
ms
      | 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 Module -> Set Module -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
needs_codegen_set
      = do
        let new_temp_file :: String -> String -> IO String
new_temp_file String
suf String
dynsuf = do
              String
tn <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
staticLife String
suf
              let dyn_tn :: String
dyn_tn = String
tn String -> String -> String
-<.> String
dynsuf
              DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
dynLife [String
dyn_tn]
              String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
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.
          --
        (String
hi_file, String
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 (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModLocation -> String
ml_hi_file ModLocation
ms_location, ModLocation -> String
ml_obj_file ModLocation
ms_location)
            else (,) (String -> String -> (String, String))
-> IO String -> IO (String -> (String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> String -> IO String
new_temp_file (DynFlags -> String
hiSuf DynFlags
dflags) (DynFlags -> String
dynHiSuf DynFlags
dflags))
                     IO (String -> (String, String)) -> IO String -> IO (String, String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> String -> IO String
new_temp_file (DynFlags -> String
objectSuf DynFlags
dflags) (DynFlags -> String
dynObjectSuf DynFlags
dflags))
        ModSummary -> IO ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> IO ModSummary) -> ModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$
          ModSummary
ms
          { ms_location :: ModLocation
ms_location =
              ModLocation
ms_location {ml_hi_file :: String
ml_hi_file = String
hi_file, ml_obj_file :: String
ml_obj_file = String
o_file}
          , ms_hspp_opts :: DynFlags
ms_hspp_opts = Int -> DynFlags -> DynFlags
updOptLevel Int
0 (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags {hscTarget :: HscTarget
hscTarget = HscTarget
target}
          }
      | Bool
otherwise = ModSummary -> IO ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms

    needs_codegen_set :: Set Module
needs_codegen_set = [ModSummary] -> Set Module
forall (t :: * -> *). Foldable t => t ModSummary -> Set Module
transitive_deps_set
      [ ModSummary
ms
      | [Either ErrorMessages ModSummary]
mss <- NodeMap [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall k a. Map k a -> [a]
Map.elems NodeMap [Either ErrorMessages ModSummary]
nodemap
      , Right ModSummary
ms <- [Either ErrorMessages ModSummary]
mss
      , ModSummary -> Bool
condition ModSummary
ms
      ]

    -- find the set of all transitive dependencies of a list of modules.
    transitive_deps_set :: t ModSummary -> Set Module
transitive_deps_set t ModSummary
modSums = (Set Module -> ModSummary -> Set Module)
-> Set Module -> t ModSummary -> Set Module
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go Set Module
forall a. Set a
Set.empty t 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 Module -> Set Module -> Bool
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.
                  | (L SrcSpan
_ ModuleName
mn, IsBoot
NotBoot) <- ModSummary -> [(Located ModuleName, IsBoot)]
msDeps ModSummary
ms
                  , ModSummary
dep_ms <-
                      Maybe [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((ModuleName, IsBoot)
-> NodeMap [Either ErrorMessages ModSummary]
-> Maybe [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModuleName
mn, IsBoot
NotBoot) NodeMap [Either ErrorMessages ModSummary]
nodemap) [[Either ErrorMessages ModSummary]]
-> ([Either ErrorMessages ModSummary]
    -> [Either ErrorMessages ModSummary])
-> [Either ErrorMessages ModSummary]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Either ErrorMessages ModSummary]
-> (Either ErrorMessages ModSummary -> [ModSummary])
-> [ModSummary]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                      Either ErrorMessages ModSummary -> [ModSummary]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
                  ]
                new_marked_mods :: Set Module
new_marked_mods = Module -> Set Module -> Set Module
forall a. Ord a => a -> Set a -> Set a
Set.insert Module
ms_mod Set Module
marked_mods
            in (Set Module -> ModSummary -> Set Module)
-> Set Module -> [ModSummary] -> Set Module
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 :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap [ModSummary]
summaries = ([Either ErrorMessages ModSummary]
 -> [Either ErrorMessages ModSummary]
 -> [Either ErrorMessages ModSummary])
-> [((ModuleName, IsBoot), [Either ErrorMessages ModSummary])]
-> NodeMap [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
forall key elt.
Ord key =>
(elt -> elt -> elt) -> [(key, elt)] -> Map key elt -> Map key elt
Map.insertListWith (([Either ErrorMessages ModSummary]
 -> [Either ErrorMessages ModSummary]
 -> [Either ErrorMessages ModSummary])
-> [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
forall a. [a] -> [a] -> [a]
(++))
                                         [ (ModSummary -> (ModuleName, IsBoot)
msKey ModSummary
s, [ModSummary -> Either ErrorMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s]) | ModSummary
s <- [ModSummary]
summaries ]
                                         NodeMap [Either ErrorMessages ModSummary]
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 -> [(Located ModuleName, IsBoot)]
msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
msDeps ModSummary
s =
    [[(Located ModuleName, IsBoot)]] -> [(Located ModuleName, IsBoot)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(Located ModuleName
m,IsBoot
IsBoot), (Located ModuleName
m,IsBoot
NotBoot)] | Located ModuleName
m <- ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
s ]
        [(Located ModuleName, IsBoot)]
-> [(Located ModuleName, IsBoot)] -> [(Located ModuleName, IsBoot)]
forall a. [a] -> [a] -> [a]
++ [ (Located ModuleName
m,IsBoot
NotBoot) | Located ModuleName
m <- ModSummary -> [Located 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
        -> [ModSummary]                 -- old summaries
        -> FilePath                     -- source file name
        -> Maybe Phase                  -- start phase
        -> Bool                         -- object code allowed?
        -> Maybe (StringBuffer,UTCTime)
        -> IO (Either ErrorMessages ModSummary)

summariseFile :: HscEnv
-> [ModSummary]
-> String
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ModSummary)
summariseFile HscEnv
hsc_env [ModSummary]
old_summaries String
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 ModSummary
old_summary <- [ModSummary] -> String -> Maybe ModSummary
findSummaryBySourceFile [ModSummary]
old_summaries String
src_fn
   = do
        let location :: ModLocation
location = ModSummary -> ModLocation
ms_location ModSummary
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
        HscEnv
-> DynFlags
-> Bool
-> IsBoot
-> (UTCTime -> IO (Either ErrorMessages ModSummary))
-> ModSummary
-> ModLocation
-> UTCTime
-> IO (Either ErrorMessages ModSummary)
forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBoot
-> (UTCTime -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ModSummary)
checkSummaryTimestamp
            HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBoot
NotBoot (String -> UTCTime -> IO (Either ErrorMessages ModSummary)
new_summary String
src_fn)
            ModSummary
old_summary ModLocation
location UTCTime
src_timestamp

   | Bool
otherwise
   = do UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
        String -> UTCTime -> IO (Either ErrorMessages ModSummary)
new_summary String
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) -> UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
                           Maybe (InputFileBuffer, UTCTime)
Nothing    -> IO UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IO UTCTime) -> IO UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getModificationUTCTime String
src_fn
                        -- getModificationUTCTime may fail

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


        -- Make a ModLocation for this file
        ModLocation
location <- IO ModLocation -> ExceptT ErrorMessages IO ModLocation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModLocation -> ExceptT ErrorMessages IO ModLocation)
-> IO ModLocation -> ExceptT ErrorMessages IO ModLocation
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> String -> IO ModLocation
mkHomeModLocation (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) ModuleName
pi_mod_name String
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 <- IO Module -> ExceptT ErrorMessages IO Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> ExceptT ErrorMessages IO Module)
-> IO Module -> ExceptT ErrorMessages IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env ModuleName
pi_mod_name ModLocation
location

        IO ModSummary -> ExceptT ErrorMessages IO ModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT ErrorMessages IO ModSummary)
-> IO ModSummary -> ExceptT ErrorMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary :: String
-> UTCTime
-> IsBoot
-> HscSource
-> ModLocation
-> Module
-> Bool
-> PreprocessedImports
-> MakeNewModSummary
MakeNewModSummary
            { nms_src_fn :: String
nms_src_fn = String
src_fn
            , nms_src_timestamp :: UTCTime
nms_src_timestamp = UTCTime
src_timestamp
            , nms_is_boot :: IsBoot
nms_is_boot = IsBoot
NotBoot
            , nms_hsc_src :: HscSource
nms_hsc_src =
                if String -> Bool
isHaskellSigFilename String
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 :: [ModSummary] -> FilePath -> Maybe ModSummary
findSummaryBySourceFile :: [ModSummary] -> String -> Maybe ModSummary
findSummaryBySourceFile [ModSummary]
summaries String
file
  = case [ ModSummary
ms | ModSummary
ms <- [ModSummary]
summaries, HscSource
HsSrcFile <- [ModSummary -> HscSource
ms_hsc_src ModSummary
ms],
                                 String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"findSummaryBySourceFile" (ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
file ] of
        [] -> Maybe ModSummary
forall a. Maybe a
Nothing
        (ModSummary
x:[ModSummary]
_) -> ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
x

checkSummaryTimestamp
    :: HscEnv -> DynFlags -> Bool -> IsBoot
    -> (UTCTime -> IO (Either e ModSummary))
    -> ModSummary -> ModLocation -> UTCTime
    -> IO (Either e ModSummary)
checkSummaryTimestamp :: HscEnv
-> DynFlags
-> Bool
-> IsBoot
-> (UTCTime -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ModSummary)
checkSummaryTimestamp
  HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBoot
is_boot UTCTime -> IO (Either e ModSummary)
new_summary
  ModSummary
old_summary ModLocation
location UTCTime
src_timestamp
  | ModSummary -> UTCTime
ms_hs_date ModSummary
old_summary UTCTime -> UTCTime -> Bool
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 HscTarget -> Bool
isObjectTarget (DynFlags -> HscTarget
hscTarget (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
                 Bool -> Bool -> Bool
|| Bool
obj_allowed -- bug #1205
                 then IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IO (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ ModLocation -> IsBoot -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBoot
is_boot
                 else Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
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 serach 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
                  (Module -> 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 <- String -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> String
ml_hie_file ModLocation
location)

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

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

-- Summarise a module, and pick up source and timestamp.
summariseModule
          :: HscEnv
          -> NodeMap ModSummary -- Map of old summaries
          -> IsBoot             -- IsBoot <=> 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 ModSummary))      -- Its new summary

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

  | Just ModSummary
old_summary <- (ModuleName, IsBoot) -> NodeMap ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModuleName
wanted_mod, IsBoot
is_boot) NodeMap ModSummary
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 ModSummary
old_summary
            src_fn :: String
src_fn = String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"summariseModule" (ModLocation -> Maybe String
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) ->
               Either ErrorMessages ModSummary
-> Maybe (Either ErrorMessages ModSummary)
forall a. a -> Maybe a
Just (Either ErrorMessages ModSummary
 -> Maybe (Either ErrorMessages ModSummary))
-> IO (Either ErrorMessages ModSummary)
-> IO (Maybe (Either ErrorMessages ModSummary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary
-> ModLocation
-> String
-> UTCTime
-> IO (Either ErrorMessages ModSummary)
check_timestamp ModSummary
old_summary ModLocation
location String
src_fn UTCTime
t
           Maybe (InputFileBuffer, UTCTime)
Nothing    -> do
                Either IOException UTCTime
m <- IO UTCTime -> IO (Either IOException UTCTime)
forall a. IO a -> IO (Either IOException a)
tryIO (String -> IO UTCTime
getModificationUTCTime String
src_fn)
                case Either IOException UTCTime
m of
                   Right UTCTime
t ->
                       Either ErrorMessages ModSummary
-> Maybe (Either ErrorMessages ModSummary)
forall a. a -> Maybe a
Just (Either ErrorMessages ModSummary
 -> Maybe (Either ErrorMessages ModSummary))
-> IO (Either ErrorMessages ModSummary)
-> IO (Maybe (Either ErrorMessages ModSummary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModSummary
-> ModLocation
-> String
-> UTCTime
-> IO (Either ErrorMessages ModSummary)
check_timestamp ModSummary
old_summary ModLocation
location String
src_fn UTCTime
t
                   Left IOException
e | IOException -> Bool
isDoesNotExistError IOException
e -> IO (Maybe (Either ErrorMessages ModSummary))
find_it
                          | Bool
otherwise             -> IOException -> IO (Maybe (Either ErrorMessages ModSummary))
forall a. IOException -> IO a
ioError IOException
e

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

    check_timestamp :: ModSummary
-> ModLocation
-> String
-> UTCTime
-> IO (Either ErrorMessages ModSummary)
check_timestamp ModSummary
old_summary ModLocation
location String
src_fn =
        HscEnv
-> DynFlags
-> Bool
-> IsBoot
-> (UTCTime -> IO (Either ErrorMessages ModSummary))
-> ModSummary
-> ModLocation
-> UTCTime
-> IO (Either ErrorMessages ModSummary)
forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBoot
-> (UTCTime -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ModSummary)
checkSummaryTimestamp
          HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBoot
is_boot
          (ModLocation
-> Module
-> String
-> UTCTime
-> IO (Either ErrorMessages ModSummary)
new_summary ModLocation
location (ModSummary -> Module
ms_mod ModSummary
old_summary) String
src_fn)
          ModSummary
old_summary ModLocation
location

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

             FindResult
_ -> Maybe (Either ErrorMessages ModSummary)
-> IO (Maybe (Either ErrorMessages ModSummary))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either ErrorMessages ModSummary)
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 ModSummary)
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' | IsBoot
IsBoot <- IsBoot
is_boot = ModLocation -> ModLocation
addBootSuffixLocn ModLocation
location
                      | Bool
otherwise         = ModLocation
location
            src_fn :: String
src_fn = String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"summarise2" (ModLocation -> Maybe String
ml_hs_file ModLocation
location')

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

    new_summary :: ModLocation
-> Module
-> String
-> UTCTime
-> IO (Either ErrorMessages ModSummary)
new_summary ModLocation
location Module
mod String
src_fn UTCTime
src_timestamp
      = ExceptT ErrorMessages IO ModSummary
-> IO (Either ErrorMessages ModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorMessages IO ModSummary
 -> IO (Either ErrorMessages ModSummary))
-> ExceptT ErrorMessages IO ModSummary
-> IO (Either ErrorMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ do
        preimps :: PreprocessedImports
preimps@PreprocessedImports {String
[(Maybe FastString, Located ModuleName)]
DynFlags
InputFileBuffer
ModuleName
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: String
pi_theimps :: [(Maybe FastString, Located ModuleName)]
pi_srcimps :: [(Maybe FastString, Located 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 -> String
pi_theimps :: PreprocessedImports -> [(Maybe FastString, Located ModuleName)]
pi_srcimps :: PreprocessedImports -> [(Maybe FastString, Located ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..}
            <- HscEnv
-> String
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env String
src_fn Maybe Phase
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 = case IsBoot
is_boot of
                IsBoot
IsBoot -> HscSource
HsBootFile
                IsBoot
_ | String -> Bool
isHaskellSigFilename String
src_fn -> HscSource
HsigFile
                  | Bool
otherwise -> HscSource
HsSrcFile

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

        Bool -> ExceptT ErrorMessages IO () -> ExceptT ErrorMessages IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Maybe Module -> Bool
forall a. Maybe a -> Bool
isNothing (ModuleName -> [(ModuleName, Module)] -> Maybe Module
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name (DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts DynFlags
dflags))) (ExceptT ErrorMessages IO () -> ExceptT ErrorMessages IO ())
-> ExceptT ErrorMessages IO () -> ExceptT ErrorMessages IO ()
forall a b. (a -> b) -> a -> b
$
            let suggested_instantiated_with :: SDoc
suggested_instantiated_with =
                    [SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                        [ ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
k SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"=" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
v
                        | (ModuleName
k,Module
v) <- ((ModuleName
pi_mod_name, ModuleName -> Module
mkHoleModule ModuleName
pi_mod_name)
                                (ModuleName, Module)
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a. a -> [a] -> [a]
: DynFlags -> [(ModuleName, Module)]
thisUnitIdInsts DynFlags
dflags)
                        ])
            in ErrorMessages -> ExceptT ErrorMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ErrorMessages -> ExceptT ErrorMessages IO ())
-> ErrorMessages -> ExceptT ErrorMessages IO ()
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrorMessages
forall a. a -> Bag a
unitBag (ErrMsg -> ErrorMessages) -> ErrMsg -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
pi_local_dflags SrcSpan
pi_mod_name_loc (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
text String
"Unexpected signature:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
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 (String -> SDoc
text String
"Try adding" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name)
                            SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"to the"
                            SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"signatures")
                            SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"field in your Cabal file.")
                    else SDoc -> SDoc
parens (String -> SDoc
text String
"Try passing -instantiated-with=\"" SDoc -> SDoc -> SDoc
<>
                                 SDoc
suggested_instantiated_with SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"\"" SDoc -> SDoc -> SDoc
$$
                                String -> SDoc
text String
"replacing <" SDoc -> SDoc -> SDoc
<> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
pi_mod_name SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"> as necessary.")

        IO ModSummary -> ExceptT ErrorMessages IO ModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT ErrorMessages IO ModSummary)
-> IO ModSummary -> ExceptT ErrorMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary :: String
-> UTCTime
-> IsBoot
-> HscSource
-> ModLocation
-> Module
-> Bool
-> PreprocessedImports
-> MakeNewModSummary
MakeNewModSummary
            { nms_src_fn :: String
nms_src_fn = String
src_fn
            , nms_src_timestamp :: UTCTime
nms_src_timestamp = UTCTime
src_timestamp
            , nms_is_boot :: IsBoot
nms_is_boot = IsBoot
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 -> String
nms_src_fn :: FilePath
      , MakeNewModSummary -> UTCTime
nms_src_timestamp :: UTCTime
      , MakeNewModSummary -> IsBoot
nms_is_boot :: IsBoot
      , 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 ModSummary
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env MakeNewModSummary{Bool
String
UTCTime
Module
ModLocation
HscSource
PreprocessedImports
IsBoot
nms_preimps :: PreprocessedImports
nms_obj_allowed :: Bool
nms_mod :: Module
nms_location :: ModLocation
nms_hsc_src :: HscSource
nms_is_boot :: IsBoot
nms_src_timestamp :: UTCTime
nms_src_fn :: String
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 -> IsBoot
nms_src_timestamp :: MakeNewModSummary -> UTCTime
nms_src_fn :: MakeNewModSummary -> String
..} = do
  let PreprocessedImports{String
[(Maybe FastString, Located ModuleName)]
DynFlags
InputFileBuffer
ModuleName
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: String
pi_theimps :: [(Maybe FastString, Located ModuleName)]
pi_srcimps :: [(Maybe FastString, Located 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 -> String
pi_theimps :: PreprocessedImports -> [(Maybe FastString, Located ModuleName)]
pi_srcimps :: PreprocessedImports -> [(Maybe FastString, Located 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 <- IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IO (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$
      if HscTarget -> Bool
isObjectTarget (DynFlags -> HscTarget
hscTarget DynFlags
dflags)
         Bool -> Bool -> Bool
|| Bool
nms_obj_allowed -- bug #1205
          then ModLocation -> IsBoot -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
nms_location IsBoot
nms_is_boot
          else Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing

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

  [(Maybe FastString, Located ModuleName)]
extra_sig_imports <- HscEnv
-> HscSource
-> ModuleName
-> IO [(Maybe FastString, Located ModuleName)]
findExtraSigImports HscEnv
hsc_env HscSource
nms_hsc_src ModuleName
pi_mod_name
  [(Maybe FastString, Located ModuleName)]
required_by_imports <- HscEnv
-> [(Maybe FastString, Located ModuleName)]
-> IO [(Maybe FastString, Located ModuleName)]
implicitRequirements HscEnv
hsc_env [(Maybe FastString, Located ModuleName)]
pi_theimps

  ModSummary -> IO ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> IO ModSummary) -> ModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ ModSummary :: Module
-> HscSource
-> ModLocation
-> UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> Maybe HsParsedModule
-> String
-> DynFlags
-> Maybe InputFileBuffer
-> ModSummary
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 :: String
ms_hspp_file = String
pi_hspp_fn
      , ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
pi_local_dflags
      , ms_hspp_buf :: Maybe InputFileBuffer
ms_hspp_buf  = InputFileBuffer -> Maybe InputFileBuffer
forall a. a -> Maybe a
Just InputFileBuffer
pi_hspp_buf
      , ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = Maybe HsParsedModule
forall a. Maybe a
Nothing
      , ms_srcimps :: [(Maybe FastString, Located ModuleName)]
ms_srcimps = [(Maybe FastString, Located ModuleName)]
pi_srcimps
      , ms_textual_imps :: [(Maybe FastString, Located ModuleName)]
ms_textual_imps =
          [(Maybe FastString, Located ModuleName)]
pi_theimps [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, Located ModuleName)]
extra_sig_imports [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
forall a. [a] -> [a] -> [a]
++ [(Maybe FastString, Located ModuleName)]
required_by_imports
      , 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
      }

getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBoot
is_boot
  = if IsBoot
is_boot IsBoot -> IsBoot -> Bool
forall a. Eq a => a -> a -> Bool
== IsBoot
IsBoot then Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
                         else String -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> String
ml_obj_file ModLocation
location)

data PreprocessedImports
  = PreprocessedImports
      { PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
      , PreprocessedImports -> [(Maybe FastString, Located ModuleName)]
pi_srcimps  :: [(Maybe FastString, Located ModuleName)]
      , PreprocessedImports -> [(Maybe FastString, Located ModuleName)]
pi_theimps  :: [(Maybe FastString, Located ModuleName)]
      , PreprocessedImports -> String
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
-> String
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env String
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf = do
  (DynFlags
pi_local_dflags, String
pi_hspp_fn)
      <- IO (Either ErrorMessages (DynFlags, String))
-> ExceptT ErrorMessages IO (DynFlags, String)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ErrorMessages (DynFlags, String))
 -> ExceptT ErrorMessages IO (DynFlags, String))
-> IO (Either ErrorMessages (DynFlags, String))
-> ExceptT ErrorMessages IO (DynFlags, String)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> String
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either ErrorMessages (DynFlags, String))
preprocess HscEnv
hsc_env String
src_fn ((InputFileBuffer, UTCTime) -> InputFileBuffer
forall a b. (a, b) -> a
fst ((InputFileBuffer, UTCTime) -> InputFileBuffer)
-> Maybe (InputFileBuffer, UTCTime) -> Maybe InputFileBuffer
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 <- IO InputFileBuffer -> ExceptT ErrorMessages IO InputFileBuffer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO InputFileBuffer -> ExceptT ErrorMessages IO InputFileBuffer)
-> IO InputFileBuffer -> ExceptT ErrorMessages IO InputFileBuffer
forall a b. (a -> b) -> a -> b
$ String -> IO InputFileBuffer
hGetStringBuffer String
pi_hspp_fn
  ([(Maybe FastString, Located ModuleName)]
pi_srcimps, [(Maybe FastString, Located ModuleName)]
pi_theimps, L SrcSpan
pi_mod_name_loc ModuleName
pi_mod_name)
      <- IO
  (Either
     ErrorMessages
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName))
-> ExceptT
     ErrorMessages
     IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO
   (Either
      ErrorMessages
      ([(Maybe FastString, Located ModuleName)],
       [(Maybe FastString, Located ModuleName)], Located ModuleName))
 -> ExceptT
      ErrorMessages
      IO
      ([(Maybe FastString, Located ModuleName)],
       [(Maybe FastString, Located ModuleName)], Located ModuleName))
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
-> ExceptT
     ErrorMessages
     IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall a b. (a -> b) -> a -> b
$ DynFlags
-> InputFileBuffer
-> String
-> String
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
getImports DynFlags
pi_local_dflags InputFileBuffer
pi_hspp_buf String
pi_hspp_fn String
src_fn
  PreprocessedImports -> ExceptT ErrorMessages IO PreprocessedImports
forall (m :: * -> *) a. Monad m => a -> m a
return PreprocessedImports :: DynFlags
-> [(Maybe FastString, Located ModuleName)]
-> [(Maybe FastString, Located ModuleName)]
-> String
-> InputFileBuffer
-> SrcSpan
-> ModuleName
-> PreprocessedImports
PreprocessedImports {String
[(Maybe FastString, Located ModuleName)]
DynFlags
InputFileBuffer
ModuleName
SrcSpan
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_theimps :: [(Maybe FastString, Located ModuleName)]
pi_srcimps :: [(Maybe FastString, Located ModuleName)]
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: String
pi_local_dflags :: DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: String
pi_theimps :: [(Maybe FastString, Located ModuleName)]
pi_srcimps :: [(Maybe FastString, Located 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 :: m a -> m a
withDeferredDiagnostics m a
f = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DeferDiagnostics DynFlags
dflags
  then m a
f
  else do
    IORef [IO ()]
warnings <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    IORef [IO ()]
errors <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    IORef [IO ()]
fatals <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []

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

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

        setLogAction :: LogAction -> m ()
setLogAction LogAction
action = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
          HscEnv
hsc_env{ hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env){ log_action :: LogAction
log_action = LogAction
action } }

    m () -> (() -> m ()) -> (() -> m a) -> m a
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket
      (LogAction -> m ()
forall (m :: * -> *). GhcMonad m => LogAction -> m ()
setLogAction LogAction
forall p.
p -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
deferDiagnostics)
      (\()
_ -> LogAction -> m ()
forall (m :: * -> *). GhcMonad m => LogAction -> m ()
setLogAction (DynFlags -> LogAction
log_action DynFlags
dflags) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
printDeferredDiagnostics)
      (\()
_ -> m a
f)

noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
-- ToDo: we don't have a proper line number for this error
noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
noModError DynFlags
dflags SrcSpan
loc ModuleName
wanted_mod FindResult
err
  = DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
loc (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> FindResult -> SDoc
cannotFindModule DynFlags
dflags ModuleName
wanted_mod FindResult
err

noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages
noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages
noHsFileErr DynFlags
dflags SrcSpan
loc String
path
  = ErrMsg -> ErrorMessages
forall a. a -> Bag a
unitBag (ErrMsg -> ErrorMessages) -> ErrMsg -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
loc (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Can't find" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
path

moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages
moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages
moduleNotFoundErr DynFlags
dflags ModuleName
mod
  = ErrMsg -> ErrorMessages
forall a. a -> Bag a
unitBag (ErrMsg -> ErrorMessages) -> ErrMsg -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
noSrcSpan (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cannot be found locally"

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

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

cyclicModuleErr :: [ModSummary] -> SDoc
-- From a strongly connected component we find
-- a single cycle to report
cyclicModuleErr :: [ModSummary] -> SDoc
cyclicModuleErr [ModSummary]
mss
  = ASSERT( not (null mss) )
    case [Node (ModuleName, IsBoot) ModSummary] -> Maybe [ModSummary]
forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node (ModuleName, IsBoot) ModSummary]
graph of
       Maybe [ModSummary]
Nothing   -> String -> SDoc
text String
"Unexpected non-cycle" SDoc -> SDoc -> SDoc
<+> [ModSummary] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModSummary]
mss
       Just [ModSummary]
path -> [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Module imports form a cycle:"
                         , Int -> SDoc -> SDoc
nest Int
2 ([ModSummary] -> SDoc
show_path [ModSummary]
path) ]
  where
    graph :: [Node NodeKey ModSummary]
    graph :: [Node (ModuleName, IsBoot) ModSummary]
graph = [ ModSummary
-> (ModuleName, IsBoot)
-> [(ModuleName, IsBoot)]
-> Node (ModuleName, IsBoot) ModSummary
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ModSummary
ms (ModSummary -> (ModuleName, IsBoot)
msKey ModSummary
ms) (ModSummary -> [(ModuleName, IsBoot)]
get_deps ModSummary
ms) | ModSummary
ms <- [ModSummary]
mss]

    get_deps :: ModSummary -> [NodeKey]
    get_deps :: ModSummary -> [(ModuleName, IsBoot)]
get_deps ModSummary
ms = ([ (Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
m, IsBoot
IsBoot)  | Located ModuleName
m <- ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
ms ] [(ModuleName, IsBoot)]
-> [(ModuleName, IsBoot)] -> [(ModuleName, IsBoot)]
forall a. [a] -> [a] -> [a]
++
                   [ (Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
m, IsBoot
NotBoot) | Located ModuleName
m <- ModSummary -> [Located ModuleName]
ms_home_imps    ModSummary
ms ])

    show_path :: [ModSummary] -> SDoc
show_path []         = String -> SDoc
forall a. String -> a
panic String
"show_path"
    show_path [ModSummary
m]        = String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms ModSummary
m
                           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"imports itself"
    show_path (ModSummary
m1:ModSummary
m2:[ModSummary]
ms) = [SDoc] -> SDoc
vcat ( Int -> SDoc -> SDoc
nest Int
7 (String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms ModSummary
m1)
                                SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: Int -> SDoc -> SDoc
nest Int
6 (String -> SDoc
text String
"imports" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms ModSummary
m2)
                                SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [ModSummary] -> [SDoc]
go [ModSummary]
ms )
       where
         go :: [ModSummary] -> [SDoc]
go []     = [String -> SDoc
text String
"which imports" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms ModSummary
m1]
         go (ModSummary
m:[ModSummary]
ms) = (String -> SDoc
text String
"which imports" SDoc -> SDoc -> SDoc
<+> ModSummary -> SDoc
ppr_ms ModSummary
m) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [ModSummary] -> [SDoc]
go [ModSummary]
ms


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