{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
module GHC.Driver.Make (
depanal, depanalE, depanalPartial, checkHomeUnitsClosed,
load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,
instantiationNodes,
downsweep,
topSortModuleGraph,
ms_home_srcimps, ms_home_imps,
summariseModule,
SummariseResult(..),
summariseFile,
hscSourceToIsBoot,
findExtraSigImports,
implicitRequirementsShallow,
noModError, cyclicModuleErr,
SummaryNode,
IsBootInterface(..), mkNodeKey,
ModNodeKey, ModNodeKeyWithUid(..),
ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith
) where
import GHC.Prelude
import GHC.Platform
import GHC.Tc.Utils.Backpack
import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM )
import GHC.Runtime.Interpreter
import qualified GHC.Linker.Loader as Linker
import GHC.Linker.Types
import GHC.Platform.Ways
import GHC.Driver.Config.Finder (initFinderOpts)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Phases
import GHC.Driver.Pipeline
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Main
import GHC.Parser.Header
import GHC.Iface.Load ( cannotFindModule )
import GHC.IfaceToCore ( typecheckIface )
import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) )
import GHC.Data.Bag ( listToBag )
import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Exception ( throwIO, SomeAsyncException )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Fingerprint
import GHC.Utils.TmpFs
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.Target
import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.PkgQual
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModDetails
import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.IORef
import Data.Maybe
import Data.Time
import Data.Bifunctor (first)
import System.Directory
import System.FilePath
import System.IO ( fixIO )
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import GHC.Driver.Pipeline.LogQueue
import qualified Data.Map.Strict as M
import GHC.Types.TypeEnv
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Class
import GHC.Driver.Env.KnotVars
import Control.Concurrent.STM
import Control.Monad.Trans.Maybe
import GHC.Runtime.Loader
import GHC.Rename.Names
import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import qualified Data.IntSet as I
import GHC.Types.Unique
depanal :: GhcMonad m =>
[ModuleName]
-> Bool
-> m ModuleGraph
depanal :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [ModuleName]
excluded_mods Bool
allow_dup_roots = do
(DriverMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots
if forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
else forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage DriverMessages
errs)
depanalE :: GhcMonad m =>
[ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [ModuleName]
excluded_mods Bool
allow_dup_roots = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
(DriverMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
if forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let one_unit_messages :: IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages
one_unit_messages IO DriverMessages
get_mod_errs UnitId
k HomeUnitEnv
hue = do
DriverMessages
errs <- IO DriverMessages
get_mod_errs
DriverMessages
unknown_module_err <- HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
k HscEnv
hsc_env) (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) ModuleGraph
mod_graph
let unused_home_mod_err :: DriverMessages
unused_home_mod_err = DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env) ModuleGraph
mod_graph
unused_pkg_err :: DriverMessages
unused_pkg_err = UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue) (HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue) ModuleGraph
mod_graph
return $ DriverMessages
errs forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_home_mod_err
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_pkg_err
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unknown_module_err
DriverMessages
all_errs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages
one_unit_messages (forall (m :: * -> *) a. Monad m => a -> m a
return forall e. Messages e
emptyMessages) (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env)
forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (DriverMessage -> GhcMessage
GhcDriverMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DriverMessages
all_errs)
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
pure (forall e. Messages e
emptyMessages, ModuleGraph
mod_graph)
else do
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG }
pure (DriverMessages
errs, ModuleGraph
emptyMG)
depanalPartial
:: GhcMonad m
=> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalPartial :: forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots = do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let
targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
old_graph :: ModuleGraph
old_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Chasing dependencies") (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (forall doc. IsLine doc => [doc] -> doc
hcat [
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Chasing modules from: ",
forall doc. IsLine doc => [doc] -> doc
hcat (forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate forall doc. IsLine doc => doc
comma (forall a b. (a -> b) -> [a] -> [b]
map Target -> SDoc
pprTarget [Target]
targets))])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FinderCache -> UnitEnv -> IO ()
flushFinderCaches (HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env) (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
([DriverMessages]
errs, [ModuleGraphNode]
graph_nodes) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep
HscEnv
hsc_env (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
old_graph)
[ModuleName]
excluded_mods Bool
allow_dup_roots
let
mod_graph :: ModuleGraph
mod_graph = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph [ModuleGraphNode]
graph_nodes
return (forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages [DriverMessages]
errs, ModuleGraph
mod_graph)
instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes UnitId
uid UnitState
unit_state = UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
uid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InstantiatedUnit]
iuids_to_check
where
iuids_to_check :: [InstantiatedUnit]
iuids_to_check :: [InstantiatedUnit]
iuids_to_check =
forall a. Ord a => [a] -> [a]
nubSort forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {unit}. GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
unit_state)
where
goUnitId :: GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId GenUnit unit
uid =
[ GenInstantiatedUnit unit
recur
| VirtUnit GenInstantiatedUnit unit
indef <- [GenUnit unit
uid]
, (ModuleName, GenModule (GenUnit unit))
inst <- forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit unit
indef
, GenInstantiatedUnit unit
recur <- (GenInstantiatedUnit unit
indef forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (ModuleName, GenModule (GenUnit unit))
inst
]
linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
linkNodes :: [ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue =
let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue
ofile :: Maybe FilePath
ofile = DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags
unit_nodes :: [NodeKey]
unit_nodes :: [NodeKey]
unit_nodes = forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== UnitId
uid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> UnitId
moduleGraphNodeUnitId) [ModuleGraphNode]
summaries)
no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
main_sum :: Bool
main_sum = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags) IsBootInterface
NotBoot) UnitId
uid)) [NodeKey]
unit_nodes
do_linking :: Bool
do_linking = Bool
main_sum Bool -> Bool -> Bool
|| Bool
no_hs_main Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib
in if | DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
== GhcLink
LinkBinary Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe FilePath
ofile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
do_linking ->
forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverRedirectedNoMain forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags))
| DynFlags -> GhcLink
ghcLink DynFlags
dflags forall a. Eq a => a -> a -> Bool
/= GhcLink
NoLink, Bool
do_linking -> forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right ([NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
unit_nodes UnitId
uid))
| Bool
otherwise -> forall a. Maybe a
Nothing
warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules DynFlags
dflags [Target]
targets ModuleGraph
mod_graph =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing
then forall e. Messages e
emptyMessages
else DriverMessages
warn
where
diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
is_known_module :: ModSummary -> Bool
is_known_module ModSummary
mod = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> Target -> Bool
is_my_target ModSummary
mod) [Target]
targets
is_my_target :: ModSummary -> Target -> Bool
is_my_target ModSummary
mod Target
target =
let tuid :: UnitId
tuid = Target -> UnitId
targetUnitId Target
target
in case Target -> TargetId
targetId Target
target of
TargetModule ModuleName
name
-> forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod) forall a. Eq a => a -> a -> Bool
== ModuleName
name
Bool -> Bool -> Bool
&& UnitId
tuid forall a. Eq a => a -> a -> Bool
== ModSummary -> UnitId
ms_unitid ModSummary
mod
TargetFile FilePath
target_file Maybe Phase
_
| Just FilePath
mod_file <- ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod)
->
DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
target_file forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||
FilePath -> FilePath
addBootSuffix FilePath
target_file forall a. Eq a => a -> a -> Bool
== FilePath
mod_file Bool -> Bool -> Bool
||
FilePath -> ModuleName
mkModuleName (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath, FilePath)
splitExtension FilePath
target_file)
forall a. Eq a => a -> a -> Bool
== forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod)
TargetId
_ -> Bool
False
missing :: [ModuleName]
missing = forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
is_known_module) forall a b. (a -> b) -> a -> b
$
(forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> ModSummary -> UnitId
ms_unitid ModSummary
ms forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
(ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph))
warn :: DriverMessages
warn = forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
forall a b. (a -> b) -> a -> b
$ UnitId -> [ModuleName] -> BuildingCabalPackage -> DriverMessage
DriverMissingHomeModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) [ModuleName]
missing (DynFlags -> BuildingCabalPackage
checkBuildingCabalPackage DynFlags
dflags)
warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules HscEnv
hsc_env DynFlags
dflags ModuleGraph
mod_graph = do
[ModuleName]
reexported_warns <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ModuleName -> IO Bool
check_reexport (forall a. Set a -> [a]
Set.toList Set ModuleName
reexported_mods)
return $ Set ModuleName -> [ModuleName] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ModuleName]
reexported_warns
where
diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
unit_mods :: Set ModuleName
unit_mods = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name
(forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> ModSummary -> UnitId
ms_unitid ModSummary
ms forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
(ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)))
reexported_mods :: Set ModuleName
reexported_mods = DynFlags -> Set ModuleName
reexportedModules DynFlags
dflags
hidden_mods :: Set ModuleName
hidden_mods = DynFlags -> Set ModuleName
hiddenModules DynFlags
dflags
hidden_warns :: Set ModuleName
hidden_warns = Set ModuleName
hidden_mods forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ModuleName
unit_mods
lookupModule :: ModuleName -> IO FindResult
lookupModule ModuleName
mn = HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
mn PkgQual
NoPkgQual
check_reexport :: ModuleName -> IO Bool
check_reexport ModuleName
mn = do
FindResult
fr <- ModuleName -> IO FindResult
lookupModule ModuleName
mn
case FindResult
fr of
Found ModLocation
_ Module
m -> forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> UnitId
moduleUnitId Module
m forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
FindResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
warn :: DriverMessage -> DriverMessages
warn DriverMessage
diagnostic = forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
forall a b. (a -> b) -> a -> b
$ DriverMessage
diagnostic
final_msgs :: Set ModuleName -> [ModuleName] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ModuleName]
reexported_warns
=
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages forall a b. (a -> b) -> a -> b
$
[DriverMessage -> DriverMessages
warn (UnitId -> [ModuleName] -> DriverMessage
DriverUnknownHiddenModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) (forall a. Set a -> [a]
Set.toList Set ModuleName
hidden_warns)) | Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set ModuleName
hidden_warns)]
forall a. [a] -> [a] -> [a]
++ [DriverMessage -> DriverMessages
warn (UnitId -> [ModuleName] -> DriverMessage
DriverUnknownReexportedModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) [ModuleName]
reexported_warns) | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
reexported_warns)]
data LoadHowMuch
= LoadAllTargets
| LoadUpTo HomeUnitModule
| LoadDependenciesOf HomeUnitModule
data ModIfaceCache = ModIfaceCache { ModIfaceCache -> IO [CachedIface]
iface_clearCache :: IO [CachedIface]
, ModIfaceCache -> CachedIface -> IO ()
iface_addToCache :: CachedIface -> IO () }
addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache ModIfaceCache
c (HomeModInfo ModIface
i ModDetails
_ HomeModLinkable
l) = ModIfaceCache -> CachedIface -> IO ()
iface_addToCache ModIfaceCache
c (ModIface -> HomeModLinkable -> CachedIface
CachedIface ModIface
i HomeModLinkable
l)
data CachedIface = CachedIface { CachedIface -> ModIface
cached_modiface :: !ModIface
, CachedIface -> HomeModLinkable
cached_linkable :: !HomeModLinkable }
instance Outputable CachedIface where
ppr :: CachedIface -> SDoc
ppr (CachedIface ModIface
mi HomeModLinkable
ln) = forall doc. IsLine doc => [doc] -> doc
hsep [forall doc. IsLine doc => FilePath -> doc
text FilePath
"CachedIface", forall a. Outputable a => a -> SDoc
ppr (ModIface -> ModNodeKeyWithUid
miKey ModIface
mi), forall a. Outputable a => a -> SDoc
ppr HomeModLinkable
ln]
noIfaceCache :: Maybe ModIfaceCache
noIfaceCache :: Maybe ModIfaceCache
noIfaceCache = forall a. Maybe a
Nothing
newIfaceCache :: IO ModIfaceCache
newIfaceCache :: IO ModIfaceCache
newIfaceCache = do
IORef [CachedIface]
ioref <- forall a. a -> IO (IORef a)
newIORef []
return $
ModIfaceCache
{ iface_clearCache :: IO [CachedIface]
iface_clearCache = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [CachedIface]
ioref (\[CachedIface]
c -> ([], [CachedIface]
c))
, iface_addToCache :: CachedIface -> IO ()
iface_addToCache = \CachedIface
hmi -> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [CachedIface]
ioref (\[CachedIface]
c -> (CachedIface
hmiforall a. a -> [a] -> [a]
:[CachedIface]
c, ()))
}
load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
load :: forall (f :: * -> *). GhcMonad f => LoadHowMuch -> f SuccessFlag
load LoadHowMuch
how_much = forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
noIfaceCache LoadHowMuch
how_much
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg HscEnv
hsc_env =
if forall (t :: * -> *) a. Foldable t => t a -> Int
length (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) forall a. Ord a => a -> a -> Bool
> Int
1
then Messager
batchMultiMsg
else Messager
batchMsg
loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
loadWithCache :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
cache LoadHowMuch
how_much = do
(DriverMessages
errs, ModuleGraph
mod_graph) <- forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (DriverMessages, ModuleGraph)
depanalE [] Bool
False
Messager
msg <- HscEnv -> Messager
mkBatchMsg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
SuccessFlag
success <- forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' Maybe ModIfaceCache
cache LoadHowMuch
how_much (forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
if forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
else forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage DriverMessages
errs)
warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
warnUnusedPackages UnitState
us DynFlags
dflags ModuleGraph
mod_graph =
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
loadedPackages :: [UnitInfo]
loadedPackages = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(PkgQual
fs, GenLocated SrcSpan ModuleName
mn) -> UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage UnitState
us (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
mn) PkgQual
fs)
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps (
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> DynFlags -> UnitId
homeUnitId_ DynFlags
dflags forall a. Eq a => a -> a -> Bool
== ModSummary -> UnitId
ms_unitid ModSummary
ms) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph))
used_args :: Set UnitId
used_args = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
loadedPackages
resolve :: (GenUnit UnitId, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg)
resolve (GenUnit UnitId
u,Maybe PackageArg
mflag) = do
PackageArg
flag <- Maybe PackageArg
mflag
UnitInfo
ui <- UnitState -> GenUnit UnitId -> Maybe UnitInfo
lookupUnit UnitState
us GenUnit UnitId
u
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Ord a => a -> Set a -> Bool
Set.notMember (forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui) Set UnitId
used_args)
return (forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui, forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
ui, forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
unitPackageVersion UnitInfo
ui, PackageArg
flag)
unusedArgs :: [(UnitId, PackageName, Version, PackageArg)]
unusedArgs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (GenUnit UnitId, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg)
resolve (UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
us)
warn :: DriverMessages
warn = forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan ([(UnitId, PackageName, Version, PackageArg)] -> DriverMessage
DriverUnusedPackages [(UnitId, PackageName, Version, PackageArg)]
unusedArgs)
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitId, PackageName, Version, PackageArg)]
unusedArgs
then forall e. Messages e
emptyMessages
else DriverMessages
warn
data ModuleGraphNodeWithBootFile
= ModuleGraphNodeWithBootFile
ModuleGraphNode
[NodeKey]
instance Outputable ModuleGraphNodeWithBootFile where
ppr :: ModuleGraphNodeWithBootFile -> SDoc
ppr (ModuleGraphNodeWithBootFile ModuleGraphNode
mgn [NodeKey]
deps) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"ModeGraphNodeWithBootFile: " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [NodeKey]
deps
data BuildPlan
= SingleModule ModuleGraphNode
| ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
| UnresolvedCycle [ModuleGraphNode]
instance Outputable BuildPlan where
ppr :: BuildPlan -> SDoc
ppr (SingleModule ModuleGraphNode
mgn) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"SingleModule" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens (forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn)
ppr (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"ResolvedCycle:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn
ppr (UnresolvedCycle [ModuleGraphNode]
mgn) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"UnresolvedCycle:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mgn
countMods :: BuildPlan -> Int
countMods :: BuildPlan -> Int
countMods (SingleModule ModuleGraphNode
_) = Int
1
countMods (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns) = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns
countMods (UnresolvedCycle [ModuleGraphNode]
ns) = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ModuleGraphNode]
ns
createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod =
let
cycle_mod_graph :: [SCC ModuleGraphNode]
cycle_mod_graph = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod
build_plan :: [BuildPlan]
build_plan :: [BuildPlan]
build_plan
| forall a. ModuleEnv a -> Bool
isEmptyModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod
| Bool
otherwise = [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
cycle_mod_graph []
toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [] [ModuleGraphNode]
mgn = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
mgn)
toBuildPlan ((AcyclicSCC ModuleGraphNode
node):[SCC ModuleGraphNode]
sccs) [ModuleGraphNode]
mgn = [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
sccs (ModuleGraphNode
nodeforall a. a -> [a] -> [a]
:[ModuleGraphNode]
mgn)
toBuildPlan ((CyclicSCC [ModuleGraphNode]
nodes):[SCC ModuleGraphNode]
sccs) [ModuleGraphNode]
mgn =
let acyclic :: [BuildPlan]
acyclic = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
mgn)
mresolved_cycle :: Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle = [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
nodes)
in [BuildPlan]
acyclic forall a. [a] -> [a] -> [a]
++ [forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([ModuleGraphNode] -> BuildPlan
UnresolvedCycle [ModuleGraphNode]
nodes) [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildPlan
ResolvedCycle Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle] forall a. [a] -> [a] -> [a]
++ [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
toBuildPlan [SCC ModuleGraphNode]
sccs []
(Graph SummaryNode
mg, NodeKey -> Maybe SummaryNode
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph)
trans_deps_map :: Map NodeKey (Set NodeKey)
trans_deps_map = forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachable Graph SummaryNode
mg (ModuleGraphNode -> NodeKey
mkNodeKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key payload. Node key payload -> payload
node_payload)
boot_path :: ModuleName -> UnitId -> [ModuleGraphNode]
boot_path ModuleName
mn UnitId
uid =
forall a b. (a -> b) -> [a] -> [b]
map (SummaryNode -> ModuleGraphNode
summaryNodeSummary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"toNode" forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
forall a. Ord a => a -> Set a -> Set a
Set.delete (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot)) forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\NodeKey
nk -> NodeKey -> UnitId
nodeKeyUnitId NodeKey
nk forall a. Eq a => a -> a -> Bool
== UnitId
uid
Bool -> Bool -> Bool
&& (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot)) forall a. Ord a => a -> Set a -> Bool
`Set.member` forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"dep_on_boot" (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
nk Map NodeKey (Set NodeKey)
trans_deps_map)) forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"not_boot_dep" (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
NotBoot)) Map NodeKey (Set NodeKey)
trans_deps_map)
where
key :: IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
ib = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
ib) UnitId
uid
boot_modules :: ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv
[ (ModSummary -> Module
ms_mod ModSummary
ms, (ModuleGraphNode
m, ModuleName -> UnitId -> [ModuleGraphNode]
boot_path (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) (ModSummary -> UnitId
ms_unitid ModSummary
ms))) | m :: ModuleGraphNode
m@(ModuleNode [NodeKey]
_ ModSummary
ms) <- (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph), ModSummary -> IsBootInterface
isBootSummary ModSummary
ms forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module)
get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module ModuleGraphNode
m = case ModuleGraphNode
m of ModuleNode [NodeKey]
_ ModSummary
ms | HscSource
HsSrcFile <- ModSummary -> HscSource
ms_hsc_src ModSummary
ms -> forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules (ModSummary -> Module
ms_mod ModSummary
ms); ModuleGraphNode
_ -> forall a. Maybe a
Nothing
collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
collapseSCC :: [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [AcyclicSCC ModuleGraphNode
node1, AcyclicSCC ModuleGraphNode
node2] = forall a. a -> Maybe a
Just [ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node1, ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node2]
collapseSCC (AcyclicSCC ModuleGraphNode
node : [SCC ModuleGraphNode]
nodes) = (ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SCC ModuleGraphNode]
-> Maybe [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [SCC ModuleGraphNode]
nodes
collapseSCC [SCC ModuleGraphNode]
_ = forall a. Maybe a
Nothing
toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot :: ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
mn =
case ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
get_boot_module ModuleGraphNode
mn of
Maybe (ModuleGraphNode, [ModuleGraphNode])
Nothing -> forall a b. a -> Either a b
Left ModuleGraphNode
mn
Just (ModuleGraphNode, [ModuleGraphNode])
path -> forall a b. b -> Either a b
Right (ModuleGraphNode -> [NodeKey] -> ModuleGraphNodeWithBootFile
ModuleGraphNodeWithBootFile ModuleGraphNode
mn (forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey (forall a b. (a, b) -> b
snd (ModuleGraphNode, [ModuleGraphNode])
path)))
collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic (AcyclicSCC ModuleGraphNode
node : [SCC ModuleGraphNode]
nodes) = ModuleGraphNode -> BuildPlan
SingleModule ModuleGraphNode
node forall a. a -> [a] -> [a]
: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic [SCC ModuleGraphNode]
nodes
collapseAcyclic (CyclicSCC [ModuleGraphNode]
cy_nodes : [SCC ModuleGraphNode]
nodes) = ([ModuleGraphNode] -> BuildPlan
UnresolvedCycle [ModuleGraphNode]
cy_nodes) forall a. a -> [a] -> [a]
: [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic [SCC ModuleGraphNode]
nodes
collapseAcyclic [] = []
topSortWithBoot :: [ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
nodes = Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
False ([ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules [ModuleGraphNode]
nodes forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
nodes) forall a. Maybe a
Nothing
in
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan) forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph))
(forall doc. IsDoc doc => [doc] -> doc
vcat [forall doc. IsLine doc => FilePath -> doc
text FilePath
"Build plan missing nodes:", (forall doc. IsLine doc => FilePath -> doc
text FilePath
"PLAN:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan))), (forall doc. IsLine doc => FilePath -> doc
text FilePath
"GRAPH:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph )))])
[BuildPlan]
build_plan
load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' Maybe ModIfaceCache
mhmi_cache LoadHowMuch
how_much Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
forall (m :: * -> *). GhcMonad m => m ()
initializeSessionPlugins
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let all_home_mods :: Set HomeUnitModule
all_home_mods =
forall a. Ord a => [a] -> Set a
Set.fromList [ forall unit. unit -> ModuleName -> GenModule unit
Module (ModSummary -> UnitId
ms_unitid ModSummary
s) (ModSummary -> ModuleName
ms_mod_name ModSummary
s)
| ModSummary
s <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph, ModSummary -> IsBootInterface
isBootSummary ModSummary
s forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot]
let checkHowMuch :: LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch (LoadUpTo HomeUnitModule
m) = HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m
checkHowMuch (LoadDependenciesOf HomeUnitModule
m) = HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m
checkHowMuch LoadHowMuch
_ = forall a. a -> a
id
checkMod :: HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m m SuccessFlag
and_then
| HomeUnitModule
m forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HomeUnitModule
all_home_mods = m SuccessFlag
and_then
| Bool
otherwise = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
errorMsg Logger
logger
(forall doc. IsLine doc => FilePath -> doc
text FilePath
"no such module:" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> unit
moduleUnit HomeUnitModule
m) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName HomeUnitModule
m)))
return SuccessFlag
Failed
LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch LoadHowMuch
how_much forall a b. (a -> b) -> a -> b
$ do
let mg2_with_srcimps :: [SCC ModuleGraphNode]
mg2_with_srcimps :: [SCC ModuleGraphNode]
mg2_with_srcimps = Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
True ModuleGraph
mod_graph forall a. Maybe a
Nothing
forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports ([SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules [SCC ModuleGraphNode]
mg2_with_srcimps)
let maybe_top_mod :: Maybe HomeUnitModule
maybe_top_mod = case LoadHowMuch
how_much of
LoadUpTo HomeUnitModule
m -> forall a. a -> Maybe a
Just HomeUnitModule
m
LoadDependenciesOf HomeUnitModule
m -> forall a. a -> Maybe a
Just HomeUnitModule
m
LoadHowMuch
_ -> forall a. Maybe a
Nothing
build_plan :: [BuildPlan]
build_plan = ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan ModuleGraph
mod_graph Maybe HomeUnitModule
maybe_top_mod
[CachedIface]
cache <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return []) ModIfaceCache -> IO [CachedIface]
iface_clearCache Maybe ModIfaceCache
mhmi_cache
let
!pruned_cache :: [HomeModInfo]
pruned_cache = [CachedIface] -> [ModSummary] -> [HomeModInfo]
pruneCache [CachedIface]
cache
(forall a. [SCC a] -> [a]
flattenSCCs ([SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules [SCC ModuleGraphNode]
mg2_with_srcimps))
let pruneHomeUnitEnv :: HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv HomeUnitEnv
hme = HomeUnitEnv
hme { homeUnitEnv_hpt :: HomePackageTable
homeUnitEnv_hpt = HomePackageTable
emptyHomePackageTable }
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC forall a b. (a -> b) -> a -> b
$ (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG (forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv) HscEnv
hsc_env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> IO ()
unload Interp
interp HscEnv
hsc_env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Ready for upsweep")
Int
2 (forall a. Outputable a => a -> SDoc
ppr [BuildPlan]
build_plan))
Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
Maybe Int
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
Just Int
n -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession forall a b. (a -> b) -> a -> b
$ (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG (forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv) HscEnv
hsc_env
(SuccessFlag
upsweep_ok, HscEnv
hsc_env1) <- forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> HscEnv
-> Maybe ModIfaceCache
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, HscEnv)
upsweep Int
n_jobs HscEnv
hsc_env Maybe ModIfaceCache
mhmi_cache Maybe Messager
mHscMessage ([HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
pruned_cache) [BuildPlan]
build_plan
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env1
case SuccessFlag
upsweep_ok of
SuccessFlag
Failed -> forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
upsweep_ok
SuccessFlag
Succeeded -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (forall doc. IsLine doc => FilePath -> doc
text FilePath
"Upsweep completely successful.")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe Logger
logger (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env1) DynFlags
dflags
forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
upsweep_ok
loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish :: forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
all_ok
= do forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardIC
return SuccessFlag
all_ok
guessOutputFile :: GhcMonad m => m ()
guessOutputFile :: forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile = forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession forall a b. (a -> b) -> a -> b
$ \HscEnv
env ->
let !mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
new_home_graph :: HomeUnitGraph
new_home_graph =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
env) forall a b. (a -> b) -> a -> b
$ \HomeUnitEnv
hue ->
let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags HomeUnitEnv
hue
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
mainModuleSrcPath :: Maybe String
mainModuleSrcPath :: Maybe FilePath
mainModuleSrcPath = do
ModSummary
ms <- ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph
mod_graph (HomeUnitEnv -> Module
mainModIs HomeUnitEnv
hue)
ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
name :: Maybe FilePath
name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
dropExtension Maybe FilePath
mainModuleSrcPath
name_exe :: Maybe FilePath
name_exe = do
!FilePath
name' <- case Platform -> ArchOS
platformArchOS Platform
platform of
ArchOS Arch
_ OS
OSMinGW32 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
<.> FilePath
"exe") Maybe FilePath
name
ArchOS Arch
ArchWasm32 OS
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
<.> FilePath
"wasm") Maybe FilePath
name
ArchOS
_ -> Maybe FilePath
name
FilePath
mainModuleSrcPath' <- Maybe FilePath
mainModuleSrcPath
if FilePath
name' forall a. Eq a => a -> a -> Bool
== FilePath
mainModuleSrcPath'
then forall a. GhcException -> a
throwGhcException forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
UsageError forall a b. (a -> b) -> a -> b
$
FilePath
"default output name would overwrite the input file; " forall a. [a] -> [a] -> [a]
++
FilePath
"must specify -o explicitly"
else forall a. a -> Maybe a
Just FilePath
name'
in
case DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags of
Just FilePath
_ -> HomeUnitEnv
hue
Maybe FilePath
Nothing -> HomeUnitEnv
hue {homeUnitEnv_dflags :: DynFlags
homeUnitEnv_dflags = DynFlags
dflags { outputFile_ :: Maybe FilePath
outputFile_ = Maybe FilePath
name_exe } }
in HscEnv
env { hsc_unit_env :: UnitEnv
hsc_unit_env = (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env) { ue_home_unit_graph :: HomeUnitGraph
ue_home_unit_graph = HomeUnitGraph
new_home_graph } }
pruneCache :: [CachedIface]
-> [ModSummary]
-> [HomeModInfo]
pruneCache :: [CachedIface] -> [ModSummary] -> [HomeModInfo]
pruneCache [CachedIface]
hpt [ModSummary]
summ
= forall a b. (a -> b) -> [a] -> [b]
strictMap CachedIface -> HomeModInfo
prune [CachedIface]
hpt
where prune :: CachedIface -> HomeModInfo
prune (CachedIface { cached_modiface :: CachedIface -> ModIface
cached_modiface = ModIface
iface
, cached_linkable :: CachedIface -> HomeModLinkable
cached_linkable = HomeModLinkable
linkable
}) = ModIface -> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
emptyModDetails HomeModLinkable
linkable'
where
modl :: ModNodeKeyWithUid
modl = ModIface -> ModNodeKeyWithUid
miKey ModIface
iface
linkable' :: HomeModLinkable
linkable'
| Just ModSummary
ms <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModNodeKeyWithUid
modl Map ModNodeKeyWithUid ModSummary
ms_map
, forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_src_hash ModIface
iface forall a. Eq a => a -> a -> Bool
/= ModSummary -> Fingerprint
ms_hs_hash ModSummary
ms
= HomeModLinkable
emptyHomeModInfoLinkable
| Bool
otherwise
= HomeModLinkable
linkable
ms_map :: Map ModNodeKeyWithUid ModSummary
ms_map = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
(\ModSummary
ms1 ModSummary
ms2 -> forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (forall doc. IsLine doc => FilePath -> doc
text FilePath
"prune_cache" forall doc. IsDoc doc => doc -> doc -> doc
$$ (forall a. Outputable a => a -> SDoc
ppr ModSummary
ms1 forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ModSummary
ms2))
ModSummary
ms2)
[(ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms, ModSummary
ms) | ModSummary
ms <- [ModSummary]
summ]
unload :: Interp -> HscEnv -> IO ()
unload :: Interp -> HscEnv -> IO ()
unload Interp
interp HscEnv
hsc_env
= case DynFlags -> GhcLink
ghcLink (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
GhcLink
LinkInMemory -> Interp -> HscEnv -> [Linkable] -> IO ()
Linker.unload Interp
interp HscEnv
hsc_env []
GhcLink
_other -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))
deriving instance Functor ResultVar
mkResultVar :: MVar (Maybe a) -> ResultVar a
mkResultVar :: forall a. MVar (Maybe a) -> ResultVar a
mkResultVar = forall b a. (a -> b) -> MVar (Maybe a) -> ResultVar b
ResultVar forall a. a -> a
id
waitResult :: ResultVar a -> MaybeT IO a
waitResult :: forall a. ResultVar a -> MaybeT IO a
waitResult (ResultVar a -> a
f MVar (Maybe a)
var) = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO a
readMVar MVar (Maybe a)
var)
data BuildResult = BuildResult { BuildResult -> ResultOrigin
_resultOrigin :: ResultOrigin
, BuildResult -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
resultVar :: ResultVar (Maybe HomeModInfo, ModuleNameSet)
}
data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Int -> ResultOrigin -> FilePath -> FilePath
[ResultOrigin] -> FilePath -> FilePath
ResultOrigin -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ResultOrigin] -> FilePath -> FilePath
$cshowList :: [ResultOrigin] -> FilePath -> FilePath
show :: ResultOrigin -> FilePath
$cshow :: ResultOrigin -> FilePath
showsPrec :: Int -> ResultOrigin -> FilePath -> FilePath
$cshowsPrec :: Int -> ResultOrigin -> FilePath -> FilePath
Show)
data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Int -> ResultLoopOrigin -> FilePath -> FilePath
[ResultLoopOrigin] -> FilePath -> FilePath
ResultLoopOrigin -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ResultLoopOrigin] -> FilePath -> FilePath
$cshowList :: [ResultLoopOrigin] -> FilePath -> FilePath
show :: ResultLoopOrigin -> FilePath
$cshow :: ResultLoopOrigin -> FilePath
showsPrec :: Int -> ResultLoopOrigin -> FilePath -> FilePath
$cshowsPrec :: Int -> ResultLoopOrigin -> FilePath -> FilePath
Show)
mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult :: ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult = ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
BuildResult
data BuildLoopState = BuildLoopState { BuildLoopState -> Map NodeKey BuildResult
buildDep :: M.Map NodeKey BuildResult
, BuildLoopState -> Int
nNODE :: Int
, BuildLoopState -> MVar HomeUnitGraph
hug_var :: MVar HomeUnitGraph
}
nodeId :: BuildM Int
nodeId :: BuildM Int
nodeId = do
Int
n <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> Int
nNODE
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { nNODE :: Int
nNODE = Int
n forall a. Num a => a -> a -> a
+ Int
1 })
return Int
n
setModulePipeline :: NodeKey -> BuildResult -> BuildM ()
setModulePipeline :: NodeKey -> BuildResult -> BuildM ()
setModulePipeline NodeKey
mgn BuildResult
build_result = do
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { buildDep :: Map NodeKey BuildResult
buildDep = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeKey
mgn BuildResult
build_result (BuildLoopState -> Map NodeKey BuildResult
buildDep BuildLoopState
m) })
type BuildMap = M.Map NodeKey BuildResult
getBuildMap :: BuildM BuildMap
getBuildMap :: BuildM (Map NodeKey BuildResult)
getBuildMap = forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> Map NodeKey BuildResult
buildDep
getDependencies :: [NodeKey] -> BuildMap -> [BuildResult]
getDependencies :: [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies [NodeKey]
direct_deps Map NodeKey BuildResult
build_map =
forall a b. (a -> b) -> [a] -> [b]
strictMap (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"dep_map" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map NodeKey BuildResult
build_map) [NodeKey]
direct_deps
type BuildM a = StateT BuildLoopState IO a
data AbstractSem = AbstractSem { AbstractSem -> IO ()
acquireSem :: IO ()
, AbstractSem -> IO ()
releaseSem :: IO () }
withAbstractSem :: AbstractSem -> IO b -> IO b
withAbstractSem :: forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
sem = forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
MC.bracket_ (AbstractSem -> IO ()
acquireSem AbstractSem
sem) (AbstractSem -> IO ()
releaseSem AbstractSem
sem)
data MakeEnv = MakeEnv { MakeEnv -> HscEnv
hsc_env :: !HscEnv
, MakeEnv -> AbstractSem
compile_sem :: !AbstractSem
, MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a
, MakeEnv -> Maybe Messager
env_messager :: !(Maybe Messager)
}
type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
interpretBuildPlan :: HomeUnitGraph
-> Maybe ModIfaceCache
-> M.Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO ( Maybe [ModuleGraphNode]
, [MakeAction]
, IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan :: HomeUnitGraph
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan HomeUnitGraph
hug Maybe ModIfaceCache
mhmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
plan = do
MVar HomeUnitGraph
hug_var <- forall a. a -> IO (MVar a)
newMVar HomeUnitGraph
hug
((Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans), BuildLoopState
build_map) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ([BuildPlan] -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plan) (Map NodeKey BuildResult
-> Int -> MVar HomeUnitGraph -> BuildLoopState
BuildLoopState forall k a. Map k a
M.empty Int
1 MVar HomeUnitGraph
hug_var)
let wait :: IO [Maybe (Maybe HomeModInfo)]
wait = forall {k}. Map k BuildResult -> IO [Maybe (Maybe HomeModInfo)]
collect_results (BuildLoopState -> Map NodeKey BuildResult
buildDep BuildLoopState
build_map)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans, IO [Maybe (Maybe HomeModInfo)]
wait)
where
collect_results :: Map k BuildResult -> IO [Maybe (Maybe HomeModInfo)]
collect_results Map k BuildResult
build_map =
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a b. (a -> b) -> [a] -> [b]
map (\BuildResult
br -> forall {a}. ResultVar a -> IO (Maybe a)
collect_result (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuildResult -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
resultVar BuildResult
br)) (forall k a. Map k a -> [a]
M.elems Map k BuildResult
build_map))
where
collect_result :: ResultVar a -> IO (Maybe a)
collect_result ResultVar a
res_var = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall a. ResultVar a -> MaybeT IO a
waitResult ResultVar a
res_var)
n_mods :: Int
n_mods = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
plan)
buildLoop :: [BuildPlan]
-> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop :: [BuildPlan] -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [])
buildLoop (BuildPlan
plan:[BuildPlan]
plans) =
case BuildPlan
plan of
SingleModule ModuleGraphNode
m -> do
MakeAction
one_plan <- Maybe [NodeKey]
-> ResultOrigin -> ModuleGraphNode -> BuildM MakeAction
buildSingleModule forall a. Maybe a
Nothing ResultOrigin
NoLoop ModuleGraphNode
m
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
all_plans) <- [BuildPlan] -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
return (Maybe [ModuleGraphNode]
cycle, MakeAction
one_plan forall a. a -> [a] -> [a]
: [MakeAction]
all_plans)
ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms -> do
[MakeAction]
pipes <- [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildM [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
graph) <- [BuildPlan] -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
return (Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipes forall a. [a] -> [a] -> [a]
++ [MakeAction]
graph)
UnresolvedCycle [ModuleGraphNode]
ns -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [ModuleGraphNode]
ns, [])
buildSingleModule :: Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> BuildM MakeAction
buildSingleModule :: Maybe [NodeKey]
-> ResultOrigin -> ModuleGraphNode -> BuildM MakeAction
buildSingleModule Maybe [NodeKey]
rehydrate_nodes ResultOrigin
origin ModuleGraphNode
mod = do
Int
mod_idx <- BuildM Int
nodeId
!Map NodeKey BuildResult
build_map <- BuildM (Map NodeKey BuildResult)
getBuildMap
MVar HomeUnitGraph
hug_var <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> MVar HomeUnitGraph
hug_var
let direct_deps :: [NodeKey]
direct_deps = Bool -> ModuleGraphNode -> [NodeKey]
nodeDependencies Bool
False ModuleGraphNode
mod
!build_deps :: [BuildResult]
build_deps = [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies [NodeKey]
direct_deps Map NodeKey BuildResult
build_map
let build_action :: RunMakeM (Maybe HomeModInfo, ModuleNameSet)
build_action =
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
mod) forall a b. (a -> b) -> a -> b
$ do
(HomeUnitGraph
hug, ModuleNameSet
deps) <- MVar HomeUnitGraph
-> [BuildResult]
-> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
wait_deps_hug MVar HomeUnitGraph
hug_var [BuildResult]
build_deps
case ModuleGraphNode
mod of
InstantiationNode UnitId
uid InstantiatedUnit
iu -> do
Int
-> Int
-> HomeUnitGraph
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode Int
mod_idx Int
n_mods HomeUnitGraph
hug UnitId
uid InstantiatedUnit
iu
return (forall a. Maybe a
Nothing, ModuleNameSet
deps)
ModuleNode [NodeKey]
_build_deps ModSummary
ms -> do
let !old_hmi :: Maybe HomeModInfo
old_hmi = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms) Map ModNodeKeyWithUid HomeModInfo
old_hpt
rehydrate_mods :: Maybe [ModuleName]
rehydrate_mods = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe ModuleName
nodeKeyModName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [NodeKey]
rehydrate_nodes
HomeModInfo
hmi <- Int
-> Int
-> Maybe HomeModInfo
-> HomeUnitGraph
-> Maybe [ModuleName]
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode Int
mod_idx Int
n_mods Maybe HomeModInfo
old_hmi HomeUnitGraph
hug Maybe [ModuleName]
rehydrate_mods ModSummary
ms
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ModIfaceCache
mhmi_cache forall a b. (a -> b) -> a -> b
$ \ModIfaceCache
hmi_cache -> ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache ModIfaceCache
hmi_cache HomeModInfo
hmi
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar HomeUnitGraph
hug_var (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> HomeUnitGraph -> HomeUnitGraph
addHomeModInfoToHug HomeModInfo
hmi)
return (forall a. a -> Maybe a
Just HomeModInfo
hmi, UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
mod) (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) ModuleNameSet
deps )
LinkNode [NodeKey]
_nks UnitId
uid -> do
HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode HomeUnitGraph
hug (Int
mod_idx, Int
n_mods) UnitId
uid [NodeKey]
direct_deps
return (forall a. Maybe a
Nothing, ModuleNameSet
deps)
MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
res_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
newEmptyMVar
let result_var :: ResultVar (Maybe HomeModInfo, ModuleNameSet)
result_var = forall a. MVar (Maybe a) -> ResultVar a
mkResultVar MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
res_var
NodeKey -> BuildResult -> BuildM ()
setModulePipeline (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mod) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult ResultOrigin
origin ResultVar (Maybe HomeModInfo, ModuleNameSet)
result_var)
return $ (forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction RunMakeM (Maybe HomeModInfo, ModuleNameSet)
build_action MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
res_var)
buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
buildOneLoopyModule (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [NodeKey]
deps) = do
MakeAction
ma <- Maybe [NodeKey]
-> ResultOrigin -> ModuleGraphNode -> BuildM MakeAction
buildSingleModule (forall a. a -> Maybe a
Just [NodeKey]
deps) (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
Initialise) ModuleGraphNode
mn
MakeAction
rehydrate_action <- ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction ResultLoopOrigin
Rehydrated ((forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
IsBoot) forall a. a -> [a] -> [a]
: (forall a b. (a -> b) -> [a] -> [b]
map (\NodeKey
d -> forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB NodeKey
d IsBootInterface
NotBoot) [NodeKey]
deps))
return $ [MakeAction
ma, MakeAction
rehydrate_action]
buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]
buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildM [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms = do
[MakeAction]
build_modules <- forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [NodeKey]
-> ResultOrigin -> ModuleGraphNode -> BuildM MakeAction
buildSingleModule forall a. Maybe a
Nothing (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
Initialise)) ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
buildOneLoopyModule) [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
let extract :: Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey
extract (Left ModuleGraphNode
mn) = forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
NotBoot
extract (Right (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [NodeKey]
_)) = forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
IsBoot
let loop_mods :: [GenWithIsBoot NodeKey]
loop_mods = forall a b. (a -> b) -> [a] -> [b]
map Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey
extract [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
MakeAction
rehydrate_action <- ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction ResultLoopOrigin
Finalised [GenWithIsBoot NodeKey]
loop_mods
return $ [MakeAction]
build_modules forall a. [a] -> [a] -> [a]
++ [MakeAction
rehydrate_action]
rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction ResultLoopOrigin
origin [GenWithIsBoot NodeKey]
deps = do
MVar HomeUnitGraph
hug_var <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> MVar HomeUnitGraph
hug_var
!Map NodeKey BuildResult
build_map <- BuildM (Map NodeKey BuildResult)
getBuildMap
MVar (Maybe ([HomeModInfo], ModuleNameSet))
res_var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
newEmptyMVar
let loop_unit :: UnitId
!loop_unit :: UnitId
loop_unit = NodeKey -> UnitId
nodeKeyUnitId (forall mod. GenWithIsBoot mod -> mod
gwib_mod (forall a. [a] -> a
head [GenWithIsBoot NodeKey]
deps))
!build_deps :: [BuildResult]
build_deps = [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies (forall a b. (a -> b) -> [a] -> [b]
map forall mod. GenWithIsBoot mod -> mod
gwib_mod [GenWithIsBoot NodeKey]
deps) Map NodeKey BuildResult
build_map
let loop_action :: RunMakeM ([HomeModInfo], ModuleNameSet)
loop_action = forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
loop_unit forall a b. (a -> b) -> a -> b
$ do
(HomeUnitGraph
hug, ModuleNameSet
tdeps) <- MVar HomeUnitGraph
-> [BuildResult]
-> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
wait_deps_hug MVar HomeUnitGraph
hug_var [BuildResult]
build_deps
HscEnv
hsc_env <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> HscEnv
hsc_env
let new_hsc :: HscEnv
new_hsc = HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
hug HscEnv
hsc_env
mns :: [ModuleName]
mns :: [ModuleName]
mns = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey -> Maybe ModuleName
nodeKeyModName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. GenWithIsBoot mod -> mod
gwib_mod) [GenWithIsBoot NodeKey]
deps
[HomeModInfo]
hmis' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> [ModuleName] -> IO [HomeModInfo]
rehydrateAfter HscEnv
new_hsc [ModuleName]
mns
forall {m :: * -> *}.
Applicative m =>
[HomeModInfo] -> [GenWithIsBoot NodeKey] -> m ()
checkRehydrationInvariant [HomeModInfo]
hmis' [GenWithIsBoot NodeKey]
deps
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar HomeUnitGraph
hug_var (\HomeUnitGraph
hug -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeModInfo -> HomeUnitGraph -> HomeUnitGraph
addHomeModInfoToHug HomeUnitGraph
hug [HomeModInfo]
hmis')
return ([HomeModInfo]
hmis', ModuleNameSet
tdeps)
let fanout :: Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> Int -> a
!! Int
i)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar (Maybe a) -> ResultVar a
mkResultVar MVar (Maybe ([HomeModInfo], ModuleNameSet))
res_var
boot_key :: NodeKey -> NodeKey
boot_key :: NodeKey -> NodeKey
boot_key (NodeKey_Module ModNodeKeyWithUid
m) = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid
m { mnkModuleName :: ModuleNameWithIsBoot
mnkModuleName = (ModNodeKeyWithUid -> ModuleNameWithIsBoot
mnkModuleName ModNodeKeyWithUid
m) { gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
IsBoot } } )
boot_key NodeKey
k = forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"boot_key" (forall a. Outputable a => a -> SDoc
ppr NodeKey
k)
update_module_pipeline :: (GenWithIsBoot NodeKey, Int) -> BuildM ()
update_module_pipeline (GenWithIsBoot NodeKey
m, Int
i) =
case forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot GenWithIsBoot NodeKey
m of
IsBootInterface
NotBoot -> NodeKey -> BuildResult -> BuildM ()
setModulePipeline (forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i))
IsBootInterface
IsBoot -> do
NodeKey -> BuildResult -> BuildM ()
setModulePipeline (forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i))
NodeKey -> BuildResult -> BuildM ()
setModulePipeline (NodeKey -> NodeKey
boot_key (forall mod. GenWithIsBoot mod -> mod
gwib_mod GenWithIsBoot NodeKey
m)) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
origin) (Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i))
let deps_i :: [(GenWithIsBoot NodeKey, Int)]
deps_i = forall a b. [a] -> [b] -> [(a, b)]
zip [GenWithIsBoot NodeKey]
deps [Int
0..]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GenWithIsBoot NodeKey, Int) -> BuildM ()
update_module_pipeline [(GenWithIsBoot NodeKey, Int)]
deps_i
return $ forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction RunMakeM ([HomeModInfo], ModuleNameSet)
loop_action MVar (Maybe ([HomeModInfo], ModuleNameSet))
res_var
checkRehydrationInvariant :: [HomeModInfo] -> [GenWithIsBoot NodeKey] -> m ()
checkRehydrationInvariant [HomeModInfo]
hmis [GenWithIsBoot NodeKey]
deps =
let hmi_names :: [ModuleName]
hmi_names = forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
start :: [ModuleName]
start = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey -> Maybe ModuleName
nodeKeyModName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. GenWithIsBoot mod -> mod
gwib_mod) [GenWithIsBoot NodeKey]
deps
in forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ([ModuleName]
hmi_names forall a. Eq a => a -> a -> Bool
== [ModuleName]
start) forall a b. (a -> b) -> a -> b
$ (forall a. Outputable a => a -> SDoc
ppr [ModuleName]
hmi_names forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [ModuleName]
start)
withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit :: forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
uid = do
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\MakeEnv
env -> MakeEnv
env { hsc_env :: HscEnv
hsc_env = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId UnitId
uid (MakeEnv -> HscEnv
hsc_env MakeEnv
env)})
upsweep
:: Int
-> HscEnv
-> Maybe ModIfaceCache
-> Maybe Messager
-> M.Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, HscEnv)
upsweep :: Int
-> HscEnv
-> Maybe ModIfaceCache
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, HscEnv)
upsweep Int
n_jobs HscEnv
hsc_env Maybe ModIfaceCache
hmi_cache Maybe Messager
mHscMessage Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan = do
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipelines, IO [Maybe (Maybe HomeModInfo)]
collect_result) <- HomeUnitGraph
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env) Maybe ModIfaceCache
hmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan
Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines Int
n_jobs HscEnv
hsc_env Maybe Messager
mHscMessage [MakeAction]
pipelines
[Maybe (Maybe HomeModInfo)]
res <- IO [Maybe (Maybe HomeModInfo)]
collect_result
let completed :: [HomeModInfo]
completed = [HomeModInfo
m | Just (Just HomeModInfo
m) <- [Maybe (Maybe HomeModInfo)]
res]
let hsc_env' :: HscEnv
hsc_env' = [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv [HomeModInfo]
completed HscEnv
hsc_env
case Maybe [ModuleGraphNode]
cycle of
Just [ModuleGraphNode]
mss -> do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
fatalErrorMsg Logger
logger ([ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss)
return (SuccessFlag
Failed, HscEnv
hsc_env)
Maybe [ModuleGraphNode]
Nothing -> do
let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
isJust [Maybe (Maybe HomeModInfo)]
res)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
success_flag, HscEnv
hsc_env')
toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
toCache :: [HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
hmis = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ModIface -> ModNodeKeyWithUid
miKey forall a b. (a -> b) -> a -> b
$ HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi, HomeModInfo
hmi) | HomeModInfo
hmi <- [HomeModInfo]
hmis])
miKey :: ModIface -> ModNodeKeyWithUid
miKey :: ModIface -> ModNodeKeyWithUid
miKey ModIface
hmi = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModIface -> ModuleNameWithIsBoot
mi_mnwib ModIface
hmi) ((GenUnit UnitId -> UnitId
toUnitId forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> unit
moduleUnit (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
hmi)))
upsweep_inst :: HscEnv
-> Maybe Messager
-> Int
-> Int
-> UnitId
-> InstantiatedUnit
-> IO ()
upsweep_inst :: HscEnv
-> Maybe Messager
-> Int
-> Int
-> UnitId
-> InstantiatedUnit
-> IO ()
upsweep_inst HscEnv
hsc_env Maybe Messager
mHscMessage Int
mod_index Int
nmods UnitId
uid InstantiatedUnit
iuid = do
case Maybe Messager
mHscMessage of
Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int
mod_index, Int
nmods) (CompileReason -> RecompileRequired
NeedsRecompile CompileReason
MustCompile) (UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
uid InstantiatedUnit
iuid)
Maybe Messager
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> GenUnit UnitId -> IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit InstantiatedUnit
iuid
pure ()
upsweep_mod :: HscEnv
-> Maybe Messager
-> Maybe HomeModInfo
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> Maybe HomeModInfo
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env Maybe Messager
mHscMessage Maybe HomeModInfo
old_hmi ModSummary
summary Int
mod_index Int
nmods = do
HomeModInfo
hmi <- Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> HomeModLinkable
-> IO HomeModInfo
compileOne' Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary
Int
mod_index Int
nmods (HomeModInfo -> ModIface
hm_iface forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HomeModInfo
old_hmi) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe HomeModLinkable
emptyHomeModInfoLinkable HomeModInfo -> HomeModLinkable
hm_linkable Maybe HomeModInfo
old_hmi)
HscEnv -> Maybe Linkable -> IO ()
addSptEntries ((HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT (\HomePackageTable
hpt -> HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
summary) HomeModInfo
hmi) HscEnv
hsc_env)
(HomeModInfo -> Maybe Linkable
homeModInfoByteCode HomeModInfo
hmi)
return HomeModInfo
hmi
addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
addSptEntries HscEnv
hsc_env Maybe Linkable
mlinkable =
HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env
[ SptEntry
spt
| Just Linkable
linkable <- [Maybe Linkable
mlinkable]
, Unlinked
unlinked <- Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
, BCOs CompiledByteCode
_ [SptEntry]
spts <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Unlinked
unlinked
, SptEntry
spt <- [SptEntry]
spts
]
topSortModuleGraph
:: Bool
-> ModuleGraph
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModuleGraph :: Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
drop_hs_boot_nodes ModuleGraph
module_graph Maybe HomeUnitModule
mb_root_mod =
Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
drop_hs_boot_nodes (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
module_graph) Maybe HomeUnitModule
mb_root_mod
topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModules :: Bool
-> [ModuleGraphNode]
-> Maybe HomeUnitModule
-> [SCC ModuleGraphNode]
topSortModules Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries Maybe HomeUnitModule
mb_root_mod
= forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> ModuleGraphNode
summaryNodeSummary) forall a b. (a -> b) -> a -> b
$ forall node. Graph node -> [SCC node]
stronglyConnCompG Graph SummaryNode
initial_graph
where
(Graph SummaryNode
graph, NodeKey -> Maybe SummaryNode
lookup_node) =
Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries
initial_graph :: Graph SummaryNode
initial_graph = case Maybe HomeUnitModule
mb_root_mod of
Maybe HomeUnitModule
Nothing -> Graph SummaryNode
graph
Just (Module UnitId
uid ModuleName
root_mod) ->
let root :: SummaryNode
root | Just SummaryNode
node <- NodeKey -> Maybe SummaryNode
lookup_node forall a b. (a -> b) -> a -> b
$ ModNodeKeyWithUid -> NodeKey
NodeKey_Module forall a b. (a -> b) -> a -> b
$ ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
root_mod IsBootInterface
NotBoot) UnitId
uid
, Graph SummaryNode
graph forall node. Graph node -> node -> Bool
`hasVertexG` SummaryNode
node
= SummaryNode
node
| Bool
otherwise
= forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
ProgramError FilePath
"module does not exist")
in forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (seq :: forall a b. a -> b -> b
seq SummaryNode
root (forall node. Graph node -> node -> [node]
reachableG Graph SummaryNode
graph SummaryNode
root))
newtype ModNodeMap a = ModNodeMap { forall a. ModNodeMap a -> Map ModuleNameWithIsBoot a
unModNodeMap :: Map.Map ModNodeKey a }
deriving (forall a b. a -> ModNodeMap b -> ModNodeMap a
forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
$c<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
fmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
$cfmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
Functor, Functor ModNodeMap
Foldable ModNodeMap
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
sequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
Traversable, forall a. Eq a => a -> ModNodeMap a -> Bool
forall a. Num a => ModNodeMap a -> a
forall a. Ord a => ModNodeMap a -> a
forall m. Monoid m => ModNodeMap m -> m
forall a. ModNodeMap a -> Bool
forall a. ModNodeMap a -> Int
forall a. ModNodeMap a -> [a]
forall a. (a -> a -> a) -> ModNodeMap a -> a
forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => ModNodeMap a -> a
$cproduct :: forall a. Num a => ModNodeMap a -> a
sum :: forall a. Num a => ModNodeMap a -> a
$csum :: forall a. Num a => ModNodeMap a -> a
minimum :: forall a. Ord a => ModNodeMap a -> a
$cminimum :: forall a. Ord a => ModNodeMap a -> a
maximum :: forall a. Ord a => ModNodeMap a -> a
$cmaximum :: forall a. Ord a => ModNodeMap a -> a
elem :: forall a. Eq a => a -> ModNodeMap a -> Bool
$celem :: forall a. Eq a => a -> ModNodeMap a -> Bool
length :: forall a. ModNodeMap a -> Int
$clength :: forall a. ModNodeMap a -> Int
null :: forall a. ModNodeMap a -> Bool
$cnull :: forall a. ModNodeMap a -> Bool
toList :: forall a. ModNodeMap a -> [a]
$ctoList :: forall a. ModNodeMap a -> [a]
foldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
fold :: forall m. Monoid m => ModNodeMap m -> m
$cfold :: forall m. Monoid m => ModNodeMap m -> m
Foldable)
emptyModNodeMap :: ModNodeMap a
emptyModNodeMap :: forall a. ModNodeMap a
emptyModNodeMap = forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap forall k a. Map k a
Map.empty
modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert :: forall a. ModuleNameWithIsBoot -> a -> ModNodeMap a -> ModNodeMap a
modNodeMapInsert ModuleNameWithIsBoot
k a
v (ModNodeMap Map ModuleNameWithIsBoot a
m) = forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ModuleNameWithIsBoot
k a
v Map ModuleNameWithIsBoot a
m)
modNodeMapElems :: ModNodeMap a -> [a]
modNodeMapElems :: forall a. ModNodeMap a -> [a]
modNodeMapElems (ModNodeMap Map ModuleNameWithIsBoot a
m) = forall k a. Map k a -> [a]
Map.elems Map ModuleNameWithIsBoot a
m
modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup :: forall a. ModuleNameWithIsBoot -> ModNodeMap a -> Maybe a
modNodeMapLookup ModuleNameWithIsBoot
k (ModNodeMap Map ModuleNameWithIsBoot a
m) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleNameWithIsBoot
k Map ModuleNameWithIsBoot a
m
modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a
modNodeMapSingleton :: forall a. ModuleNameWithIsBoot -> a -> ModNodeMap a
modNodeMapSingleton ModuleNameWithIsBoot
k a
v = forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (forall k a. k -> a -> Map k a
M.singleton ModuleNameWithIsBoot
k a
v)
modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a
modNodeMapUnionWith :: forall a.
(a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a
modNodeMapUnionWith a -> a -> a
f (ModNodeMap Map ModuleNameWithIsBoot a
m) (ModNodeMap Map ModuleNameWithIsBoot a
n) = forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith a -> a -> a
f Map ModuleNameWithIsBoot a
m Map ModuleNameWithIsBoot a
n)
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports :: forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
sccs = do
DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
Opt_WarnUnusedImports DiagOpts
diag_opts) forall a b. (a -> b) -> a -> b
$ do
let check :: [ModSummary] -> [MsgEnvelope GhcMessage]
check [ModSummary]
ms =
let mods_in_this_cycle :: [ModuleName]
mods_in_this_cycle = forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
ms in
[ GenLocated SrcSpan ModuleName -> MsgEnvelope GhcMessage
warn GenLocated SrcSpan ModuleName
i | ModSummary
m <- [ModSummary]
ms, GenLocated SrcSpan ModuleName
i <- ModSummary -> [GenLocated SrcSpan ModuleName]
ms_home_srcimps ModSummary
m,
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
mods_in_this_cycle ]
warn :: Located ModuleName -> MsgEnvelope GhcMessage
warn :: GenLocated SrcSpan ModuleName -> MsgEnvelope GhcMessage
warn (L SrcSpan
loc ModuleName
mod) = DriverMessage -> GhcMessage
GhcDriverMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts
SrcSpan
loc (ModuleName -> DriverMessage
DriverUnnecessarySourceImports ModuleName
mod)
forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Bag a
listToBag (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ModSummary] -> [MsgEnvelope GhcMessage]
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs))
type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep HscEnv
hsc_env [ModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots
= do
[Either (UnitId, DriverMessages) ModSummary]
rootSummaries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary [Target]
roots
let ([(UnitId, DriverMessages)]
root_errs, [ModSummary]
rootSummariesOk) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (UnitId, DriverMessages) ModSummary]
rootSummaries
root_map :: DownsweepCache
root_map = [ModSummary] -> DownsweepCache
mkRootMap [ModSummary]
rootSummariesOk
DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
(Map NodeKey ModuleGraphNode
deps, Set (UnitId, UnitId)
pkg_deps, DownsweepCache
map0) <- [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
rootSummariesOk (forall k a. Map k a
M.empty, forall a. Set a
Set.empty, DownsweepCache
root_map)
let closure_errs :: [DriverMessages]
closure_errs = UnitEnv -> Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) (forall a. Set a -> [a]
Set.toList Set (UnitId, UnitId)
pkg_deps)
let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
let downsweep_errs :: [DriverMessages]
downsweep_errs = forall a b. [Either a b] -> [a]
lefts forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems DownsweepCache
map0
downsweep_nodes :: [ModuleGraphNode]
downsweep_nodes = forall k a. Map k a -> [a]
M.elems Map NodeKey ModuleGraphNode
deps
([DriverMessages]
other_errs, [ModuleGraphNode]
unit_nodes) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey (\[Either DriverMessages ModuleGraphNode]
nodes UnitId
uid HomeUnitEnv
hue -> [Either DriverMessages ModuleGraphNode]
nodes forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
downsweep_nodes UnitId
uid HomeUnitEnv
hue) [] (HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env)
all_nodes :: [ModuleGraphNode]
all_nodes = [ModuleGraphNode]
downsweep_nodes forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
unit_nodes
all_errs :: [DriverMessages]
all_errs = [DriverMessages]
all_root_errs forall a. [a] -> [a] -> [a]
++ [DriverMessages]
downsweep_errs forall a. [a] -> [a] -> [a]
++ [DriverMessages]
other_errs
all_root_errs :: [DriverMessages]
all_root_errs = [DriverMessages]
closure_errs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(UnitId, DriverMessages)]
root_errs
[ModuleGraphNode]
th_enabled_nodes <- Logger
-> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO [ModuleGraphNode]
enableCodeGenForTH Logger
logger TmpFs
tmpfs UnitEnv
unit_env [ModuleGraphNode]
all_nodes
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DriverMessages]
all_root_errs
then forall (m :: * -> *) a. Monad m => a -> m a
return ([DriverMessages]
all_errs, [ModuleGraphNode]
th_enabled_nodes)
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([DriverMessages]
all_root_errs, [])
where
unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
unitModuleNodes :: [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
summaries UnitId
uid HomeUnitEnv
hue =
let instantiation_nodes :: [ModuleGraphNode]
instantiation_nodes = UnitId -> UnitState -> [ModuleGraphNode]
instantiationNodes UnitId
uid (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue)
in forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [ModuleGraphNode]
instantiation_nodes
forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList ([ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes ([ModuleGraphNode]
instantiation_nodes forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
summaries) UnitId
uid HomeUnitEnv
hue)
calcDeps :: ModSummary
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
calcDeps ModSummary
ms =
[(ModSummary -> UnitId
ms_unitid ModSummary
ms, PkgQual
NoPkgQual, forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot) | IsBootInterface
NotBoot <- [ModSummary -> IsBootInterface
isBootSummary ModSummary
ms] ] forall a. [a] -> [a] -> [a]
++
[(ModSummary -> UnitId
ms_unitid ModSummary
ms, PkgQual
b, GenWithIsBoot (GenLocated SrcSpan ModuleName)
c) | (PkgQual
b, GenWithIsBoot (GenLocated SrcSpan ModuleName)
c) <- ModSummary
-> [(PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
msDeps ModSummary
ms ]
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
roots :: [Target]
roots = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
old_summary_map :: M.Map (UnitId, FilePath) ModSummary
old_summary_map :: Map (UnitId, FilePath) ModSummary
old_summary_map = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((ModSummary -> UnitId
ms_unitid ModSummary
ms, ModSummary -> FilePath
msHsFilePath ModSummary
ms), ModSummary
ms) | ModSummary
ms <- [ModSummary]
old_summaries]
getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary Target { targetId :: Target -> TargetId
targetId = TargetFile FilePath
file Maybe Phase
mb_phase
, targetContents :: Target -> Maybe (InputFileBuffer, UTCTime)
targetContents = Maybe (InputFileBuffer, UTCTime)
maybe_buf
, targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid
}
= do let offset_file :: FilePath
offset_file = DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
file
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
offset_file
if Bool
exists Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe (InputFileBuffer, UTCTime)
maybe_buf
then forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (UnitId
uid,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map FilePath
offset_file Maybe Phase
mb_phase
Maybe (InputFileBuffer, UTCTime)
maybe_buf
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (UnitId
uid,) forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage
forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (FilePath -> DriverMessage
DriverFileNotFound FilePath
offset_file)
where
dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))
home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
getRootSummary Target { targetId :: Target -> TargetId
targetId = TargetModule ModuleName
modl
, targetContents :: Target -> Maybe (InputFileBuffer, UTCTime)
targetContents = Maybe (InputFileBuffer, UTCTime)
maybe_buf
, targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid
}
= do SummariseResult
maybe_summary <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
NotBoot
(forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) (UnitId -> PkgQual
ThisPkg (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit))
Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
case SummariseResult
maybe_summary of
FoundHome ModSummary
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ModSummary
s)
FoundHomeWithError (UnitId, DriverMessages)
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (UnitId, DriverMessages)
err)
SummariseResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ (UnitId
uid, ModuleName -> DriverMessages
moduleNotFoundErr ModuleName
modl)
where
home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")
checkDuplicates
:: DownsweepCache
-> IO ()
checkDuplicates :: DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
| Bool
allow_dup_roots = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModSummary]]
dup_roots = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [ModSummary] -> IO ()
multiRootsErr (forall a. [a] -> a
head [[ModSummary]]
dup_roots)
where
dup_roots :: [[ModSummary]]
dup_roots :: [[ModSummary]]
dup_roots = forall a. (a -> Bool) -> [a] -> [a]
filterOut forall a. [a] -> Bool
isSingleton forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. [Either a b] -> [b]
rights (forall k a. Map k a -> [a]
M.elems DownsweepCache
root_map)
loopSummaries :: [ModSummary]
-> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),
DownsweepCache)
-> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)
loopSummaries :: [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [] (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
done = forall (m :: * -> *) a. Monad m => a -> m a
return (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
done
loopSummaries (ModSummary
ms:[ModSummary]
next) (Map NodeKey ModuleGraphNode
done, Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised)
| Just {} <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
k Map NodeKey ModuleGraphNode
done
= [ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
next (Map NodeKey ModuleGraphNode
done, Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised)
| Bool
otherwise = do
([NodeKey]
final_deps, Set (UnitId, UnitId)
pkgs1, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports (ModSummary
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
calcDeps ModSummary
ms) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey]
_, Set (UnitId, UnitId)
_, Map NodeKey ModuleGraphNode
done'', DownsweepCache
summarised'') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports (forall a. Maybe a -> [a]
maybeToList Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
hs_file_for_boot) Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'
[ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary]
next (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeKey
k ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
final_deps ModSummary
ms) Map NodeKey ModuleGraphNode
done'', Set (UnitId, UnitId)
pkgs1 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (UnitId, UnitId)
pkgs, DownsweepCache
summarised'')
where
k :: NodeKey
k = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms)
hs_file_for_boot :: Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
hs_file_for_boot
| HscSource
HsBootFile <- ModSummary -> HscSource
ms_hsc_src ModSummary
ms = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ((ModSummary -> UnitId
ms_unitid ModSummary
ms), PkgQual
NoPkgQual, (forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (forall e. e -> Located e
noLoc forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
NotBoot))
| Bool
otherwise = forall a. Maybe a
Nothing
loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> M.Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Set.Set (UnitId, UnitId),
M.Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports :: [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [] Map NodeKey ModuleGraphNode
done DownsweepCache
summarised = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Set a
Set.empty, Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
loopImports ((UnitId
home_uid,PkgQual
mb_pkg, GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib) : [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
| Just [Either DriverMessages ModSummary]
summs <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key DownsweepCache
summarised
= case [Either DriverMessages ModSummary]
summs of
[Right ModSummary
ms] -> do
let nk :: NodeKey
nk = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms)
([NodeKey]
rest, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeKey
nkforall a. a -> [a] -> [a]
: [NodeKey]
rest, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done')
[Left DriverMessages
_err] ->
[(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
[Either DriverMessages ModSummary]
_errs -> do
[(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
| Bool
otherwise
= do
SummariseResult
mb_s <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map
IsBootInterface
is_boot GenLocated SrcSpan ModuleName
wanted_mod PkgQual
mb_pkg
forall a. Maybe a
Nothing [ModuleName]
excl_mods
case SummariseResult
mb_s of
SummariseResult
NotThere -> [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
External UnitId
uid -> do
([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
forall (m :: * -> *) a. Monad m => a -> m a
return ([NodeKey]
other_deps, forall a. Ord a => a -> Set a -> Set a
Set.insert (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit, UnitId
uid) Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
FoundInstantiation InstantiatedUnit
iud -> do
([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
forall (m :: * -> *) a. Monad m => a -> m a
return (InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
iud forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
FoundHomeWithError (UnitId
_uid, DriverMessages
e) -> [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [(forall a b. a -> Either a b
Left DriverMessages
e)] DownsweepCache
summarised)
FoundHome ModSummary
s -> do
(Map NodeKey ModuleGraphNode
done', Set (UnitId, UnitId)
pkgs1, DownsweepCache
summarised') <-
[ModSummary]
-> (Map NodeKey ModuleGraphNode, Set (UnitId, UnitId),
DownsweepCache)
-> IO
(Map NodeKey ModuleGraphNode, Set (UnitId, UnitId), DownsweepCache)
loopSummaries [ModSummary
s] (Map NodeKey ModuleGraphNode
done, forall a. Set a
Set.empty, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [forall a b. b -> Either a b
Right ModSummary
s] DownsweepCache
summarised)
([NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs2, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised) <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO
([NodeKey], Set (UnitId, UnitId), Map NodeKey ModuleGraphNode,
DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'
forall (m :: * -> *) a. Monad m => a -> m a
return (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
s) forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Set (UnitId, UnitId)
pkgs1 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (UnitId, UnitId)
pkgs2, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised)
where
cache_key :: (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key = (UnitId
home_uid, PkgQual
mb_pkg, forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib)
home_unit :: HomeUnit
home_unit = UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit UnitId
home_uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
GWIB { gwib_mod :: forall mod. GenWithIsBoot mod -> mod
gwib_mod = L SrcSpan
loc ModuleName
mod, gwib_isBoot :: forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot = IsBootInterface
is_boot } = GenWithIsBoot (GenLocated SrcSpan ModuleName)
gwib
wanted_mod :: GenLocated SrcSpan ModuleName
wanted_mod = forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ModuleName
mod
checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed :: UnitEnv -> Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
checkHomeUnitsClosed UnitEnv
ue Set UnitId
home_id_set [(UnitId, UnitId)]
home_imp_ids
| forall a. Set a -> Int
Set.size Set UnitId
home_id_set forall a. Eq a => a -> a -> Bool
== Int
1 = []
| Bool
otherwise =
let res :: Set UnitId
res = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (UnitId, UnitId) -> Set UnitId
loop [(UnitId, UnitId)]
home_imp_ids
bad_unit_ids :: Set UnitId
bad_unit_ids = forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set UnitId
res Set UnitId
home_id_set
in if forall a. Set a -> Bool
Set.null Set UnitId
bad_unit_ids
then []
else [forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
rootLoc forall a b. (a -> b) -> a -> b
$ [UnitId] -> DriverMessage
DriverHomePackagesNotClosed (forall a. Set a -> [a]
Set.toList Set UnitId
bad_unit_ids)]
where
rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")
loop :: (UnitId, UnitId) -> Set.Set UnitId
loop :: (UnitId, UnitId) -> Set UnitId
loop (UnitId
from_uid, UnitId
uid) =
let us :: HomeUnitEnv
us = HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
from_uid UnitEnv
ue in
let um :: UnitInfoMap
um = UnitState -> UnitInfoMap
unitInfoMap (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
us) in
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid UnitInfoMap
um of
Maybe UnitInfo
Nothing -> forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"uid not found" (forall a. Outputable a => a -> SDoc
ppr UnitId
uid)
Just UnitInfo
ui ->
let depends :: [UnitId]
depends = forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
ui
home_depends :: Set UnitId
home_depends = forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
depends forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set UnitId
home_id_set
other_depends :: Set UnitId
other_depends = forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
depends forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set UnitId
home_id_set
in
if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set UnitId
home_depends)
then
let res :: Set UnitId
res = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((UnitId, UnitId) -> Set UnitId
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId
from_uid,)) Set UnitId
other_depends
in forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
res
else
let res :: Set UnitId
res = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((UnitId, UnitId) -> Set UnitId
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId
from_uid,)) Set UnitId
other_depends
in
if Bool -> Bool
not (forall a. Set a -> Bool
Set.null Set UnitId
res)
then forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
res
else Set UnitId
res
enableCodeGenForTH
:: Logger
-> TmpFs
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenForTH :: Logger
-> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO [ModuleGraphNode]
enableCodeGenForTH Logger
logger TmpFs
tmpfs UnitEnv
unit_env =
Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenWhen Logger
logger TmpFs
tmpfs TempFileLifetime
TFL_CurrentModule TempFileLifetime
TFL_GhcSession UnitEnv
unit_env
data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (CodeGenEnable -> CodeGenEnable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CodeGenEnable -> CodeGenEnable -> Bool
$c/= :: CodeGenEnable -> CodeGenEnable -> Bool
== :: CodeGenEnable -> CodeGenEnable -> Bool
$c== :: CodeGenEnable -> CodeGenEnable -> Bool
Eq, Int -> CodeGenEnable -> FilePath -> FilePath
[CodeGenEnable] -> FilePath -> FilePath
CodeGenEnable -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [CodeGenEnable] -> FilePath -> FilePath
$cshowList :: [CodeGenEnable] -> FilePath -> FilePath
show :: CodeGenEnable -> FilePath
$cshow :: CodeGenEnable -> FilePath
showsPrec :: Int -> CodeGenEnable -> FilePath -> FilePath
$cshowsPrec :: Int -> CodeGenEnable -> FilePath -> FilePath
Show, Eq CodeGenEnable
CodeGenEnable -> CodeGenEnable -> Bool
CodeGenEnable -> CodeGenEnable -> Ordering
CodeGenEnable -> CodeGenEnable -> CodeGenEnable
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 :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
$cmin :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
max :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
$cmax :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
>= :: CodeGenEnable -> CodeGenEnable -> Bool
$c>= :: CodeGenEnable -> CodeGenEnable -> Bool
> :: CodeGenEnable -> CodeGenEnable -> Bool
$c> :: CodeGenEnable -> CodeGenEnable -> Bool
<= :: CodeGenEnable -> CodeGenEnable -> Bool
$c<= :: CodeGenEnable -> CodeGenEnable -> Bool
< :: CodeGenEnable -> CodeGenEnable -> Bool
$c< :: CodeGenEnable -> CodeGenEnable -> Bool
compare :: CodeGenEnable -> CodeGenEnable -> Ordering
$ccompare :: CodeGenEnable -> CodeGenEnable -> Ordering
Ord)
instance Outputable CodeGenEnable where
ppr :: CodeGenEnable -> SDoc
ppr = forall doc. IsLine doc => FilePath -> doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show
enableCodeGenWhen
:: Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenWhen :: Logger
-> TmpFs
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
enableCodeGenWhen Logger
logger TmpFs
tmpfs TempFileLifetime
staticLife TempFileLifetime
dynLife UnitEnv
unit_env [ModuleGraphNode]
mod_graph =
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen [ModuleGraphNode]
mod_graph
where
defaultBackendOf :: ModSummary -> Backend
defaultBackendOf ModSummary
ms = Platform -> Backend
platformDefaultBackend (DynFlags -> Platform
targetPlatform forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitId -> UnitEnv -> DynFlags
ue_unitFlags (ModSummary -> UnitId
ms_unitid ModSummary
ms) UnitEnv
unit_env)
enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen n :: ModuleGraphNode
n@(ModuleNode [NodeKey]
deps ModSummary
ms)
| ModSummary
{ ms_location :: ModSummary -> ModLocation
ms_location = ModLocation
ms_location
, ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
HsSrcFile
, ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags
} <- ModSummary
ms
, Just CodeGenEnable
enable_spec <- ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
n forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map NodeKey CodeGenEnable
needs_codegen_map =
if | ModSummary -> Bool
nocode_enable ModSummary
ms -> do
let new_temp_file :: FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file FilePath
suf FilePath
dynsuf = do
FilePath
tn <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
staticLife FilePath
suf
let dyn_tn :: FilePath
dyn_tn = FilePath
tn FilePath -> FilePath -> FilePath
-<.> FilePath
dynsuf
TmpFs -> TempFileLifetime -> [FilePath] -> IO ()
addFilesToClean TmpFs
tmpfs TempFileLifetime
dynLife [FilePath
dyn_tn]
return (FilePath
tn, FilePath
dyn_tn)
((FilePath
hi_file, FilePath
dyn_hi_file), (FilePath
o_file, FilePath
dyn_o_file)) <-
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
then forall (m :: * -> *) a. Monad m => a -> m a
return ((ModLocation -> FilePath
ml_hi_file ModLocation
ms_location, ModLocation -> FilePath
ml_dyn_hi_file ModLocation
ms_location)
, (ModLocation -> FilePath
ml_obj_file ModLocation
ms_location, ModLocation -> FilePath
ml_dyn_obj_file ModLocation
ms_location))
else (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file (DynFlags -> FilePath
hiSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynHiSuf_ DynFlags
dflags))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> FilePath -> IO (FilePath, FilePath)
new_temp_file (DynFlags -> FilePath
objectSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynObjectSuf_ DynFlags
dflags))
let new_dflags :: DynFlags
new_dflags = case CodeGenEnable
enable_spec of
CodeGenEnable
EnableByteCode -> DynFlags
dflags { backend :: Backend
backend = Backend
interpreterBackend }
CodeGenEnable
EnableObject -> DynFlags
dflags { backend :: Backend
backend = ModSummary -> Backend
defaultBackendOf ModSummary
ms }
CodeGenEnable
EnableByteCodeAndObject -> (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_ByteCodeAndObjectCode) { backend :: Backend
backend = ModSummary -> Backend
defaultBackendOf ModSummary
ms}
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_location :: ModLocation
ms_location =
ModLocation
ms_location { ml_hi_file :: FilePath
ml_hi_file = FilePath
hi_file
, ml_obj_file :: FilePath
ml_obj_file = FilePath
o_file
, ml_dyn_hi_file :: FilePath
ml_dyn_hi_file = FilePath
dyn_hi_file
, ml_dyn_obj_file :: FilePath
ml_dyn_obj_file = FilePath
dyn_o_file }
, ms_hspp_opts :: DynFlags
ms_hspp_opts = Int -> DynFlags -> DynFlags
updOptLevel Int
0 forall a b. (a -> b) -> a -> b
$ DynFlags
new_dflags
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| CodeGenEnable -> ModSummary -> Bool
bytecode_and_enable CodeGenEnable
enable_spec ModSummary
ms -> do
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> GeneralFlag -> DynFlags
gopt_set (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) GeneralFlag
Opt_ByteCodeAndObjectCode
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
enable_spec ModSummary
ms -> do
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> GeneralFlag -> DynFlags
gopt_set (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) GeneralFlag
Opt_BuildDynamicToo
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| ModSummary -> Bool
ext_interp_enable ModSummary
ms -> do
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> GeneralFlag -> DynFlags
gopt_set (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) GeneralFlag
Opt_ExternalInterpreter
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraphNode
n
enable_code_gen ModuleGraphNode
ms = forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraphNode
ms
nocode_enable :: ModSummary -> Bool
nocode_enable ms :: ModSummary
ms@(ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
Bool -> Bool
not (Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend DynFlags
dflags)) Bool -> Bool -> Bool
&&
forall u. GenHomeUnit u -> Bool
isHomeUnitDefinite (UnitId -> UnitEnv -> HomeUnit
ue_unitHomeUnit (ModSummary -> UnitId
ms_unitid ModSummary
ms) UnitEnv
unit_env)
bytecode_and_enable :: CodeGenEnable -> ModSummary -> Bool
bytecode_and_enable CodeGenEnable
enable_spec ModSummary
ms =
CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
EnableObject ModSummary
ms
Bool -> Bool -> Bool
&& Bool
prefer_bytecode
Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
generate_both
where
lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
prefer_bytecode :: Bool
prefer_bytecode = case CodeGenEnable
enable_spec of
CodeGenEnable
EnableByteCodeAndObject -> Bool
True
CodeGenEnable
EnableByteCode -> Bool
True
CodeGenEnable
EnableObject -> Bool
False
generate_both :: Bool
generate_both = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ByteCodeAndObjectCode DynFlags
lcl_dflags
dynamic_too_enable :: CodeGenEnable -> ModSummary -> Bool
dynamic_too_enable CodeGenEnable
enable_spec ModSummary
ms
= Bool
hostIsDynamic Bool -> Bool -> Bool
&& Bool
internalInterpreter Bool -> Bool -> Bool
&&
Bool -> Bool
not Bool
isDynWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isProfWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
dyn_too_enabled
Bool -> Bool -> Bool
&& Bool
enable_object
where
lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
lcl_dflags)
dyn_too_enabled :: Bool
dyn_too_enabled = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
lcl_dflags
isDynWay :: Bool
isDynWay = Ways -> Way -> Bool
hasWay (DynFlags -> Ways
ways DynFlags
lcl_dflags) Way
WayDyn
isProfWay :: Bool
isProfWay = Ways -> Way -> Bool
hasWay (DynFlags -> Ways
ways DynFlags
lcl_dflags) Way
WayProf
enable_object :: Bool
enable_object = case CodeGenEnable
enable_spec of
CodeGenEnable
EnableByteCode -> Bool
False
CodeGenEnable
EnableByteCodeAndObject -> Bool
True
CodeGenEnable
EnableObject -> Bool
True
ext_interp_enable :: ModSummary -> Bool
ext_interp_enable ModSummary
ms = Bool -> Bool
not Bool
ghciSupported Bool -> Bool -> Bool
&& Bool
internalInterpreter
where
lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
internalInterpreter :: Bool
internalInterpreter = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
lcl_dflags)
(Graph SummaryNode
mg, NodeKey -> Maybe SummaryNode
lookup_node) = Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False [ModuleGraphNode]
mod_graph
mk_needed_set :: [NodeKey] -> Set NodeKey
mk_needed_set [NodeKey]
roots = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ModuleGraphNode -> NodeKey
mkNodeKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key payload. Node key payload -> payload
node_payload) forall a b. (a -> b) -> a -> b
$ forall node. Graph node -> [node] -> [node]
reachablesG Graph SummaryNode
mg (forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"needs_th" forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node) [NodeKey]
roots)
needs_obj_set, needs_bc_set :: Set.Set NodeKey
needs_obj_set :: Set NodeKey
needs_obj_set = [NodeKey] -> Set NodeKey
mk_needed_set [NodeKey]
need_obj_set
needs_bc_set :: Set NodeKey
needs_bc_set = [NodeKey] -> Set NodeKey
mk_needed_set [NodeKey]
need_bc_set
needs_codegen_map :: Map.Map NodeKey CodeGenEnable
needs_codegen_map :: Map NodeKey CodeGenEnable
needs_codegen_map =
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\CodeGenEnable
_ CodeGenEnable
_ -> CodeGenEnable
EnableByteCodeAndObject)
(forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ [(NodeKey
m, CodeGenEnable
EnableObject) | NodeKey
m <- forall a. Set a -> [a]
Set.toList Set NodeKey
needs_obj_set])
(forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ [(NodeKey
m, CodeGenEnable
EnableByteCode) | NodeKey
m <- forall a. Set a -> [a]
Set.toList Set NodeKey
needs_bc_set])
need_obj_set :: [NodeKey]
need_obj_set =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [NodeKey]
deps
| (ModuleNode [NodeKey]
deps ModSummary
ms) <- [ModuleGraphNode]
mod_graph
, ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
, Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UseBytecodeRatherThanObjects (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms))
]
need_bc_set :: [NodeKey]
need_bc_set =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [NodeKey]
deps
| (ModuleNode [NodeKey]
deps ModSummary
ms) <- [ModuleGraphNode]
mod_graph
, ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
, GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_UseBytecodeRatherThanObjects (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)
]
mkRootMap
:: [ModSummary]
-> DownsweepCache
mkRootMap :: [ModSummary] -> DownsweepCache
mkRootMap [ModSummary]
summaries = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> [a] -> [a]
(++))
[ ((ModSummary -> UnitId
ms_unitid ModSummary
s, PkgQual
NoPkgQual, ModSummary -> ModuleNameWithIsBoot
ms_mnwib ModSummary
s), [forall a b. b -> Either a b
Right ModSummary
s]) | ModSummary
s <- [ModSummary]
summaries ]
summariseFile
:: HscEnv
-> HomeUnit
-> M.Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer,UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either DriverMessages ModSummary)
summariseFile HscEnv
hsc_env' HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf
| Just ModSummary
old_summary <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit, FilePath
src_fn) Map (UnitId, FilePath) ModSummary
old_summaries
= do
let location :: ModLocation
location = ModSummary -> ModLocation
ms_location forall a b. (a -> b) -> a -> b
$ ModSummary
old_summary
Fingerprint
src_hash <- IO Fingerprint
get_src_hash
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash
HscEnv
hsc_env (FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn)
ModSummary
old_summary ModLocation
location Fingerprint
src_hash
| Bool
otherwise
= do Fingerprint
src_hash <- IO Fingerprint
get_src_hash
FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn Fingerprint
src_hash
where
hsc_env :: HscEnv
hsc_env = HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'
get_src_hash :: IO Fingerprint
get_src_hash = case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
Just (InputFileBuffer
buf,UTCTime
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InputFileBuffer -> Fingerprint
fingerprintStringBuffer InputFileBuffer
buf
Maybe (InputFileBuffer, UTCTime)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Fingerprint
getFileHash FilePath
src_fn
new_summary :: FilePath -> Fingerprint -> IO (Either DriverMessages ModSummary)
new_summary FilePath
src_fn Fingerprint
src_hash = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
DynFlags
SrcSpan
InputFileBuffer
ModuleName
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_ghc_prim_import :: Bool
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}
<- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf
let fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
let location :: ModLocation
location = FinderOpts -> ModuleName -> FilePath -> ModLocation
mkHomeModLocation FinderOpts
fopts ModuleName
pi_mod_name FilePath
src_fn
Module
mod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder FinderCache
fc HomeUnit
home_unit ModuleName
pi_mod_name ModLocation
location
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
{ nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
, nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
, nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
NotBoot
, nms_hsc_src :: HscSource
nms_hsc_src =
if FilePath -> Bool
isHaskellSigFilename FilePath
src_fn
then HscSource
HsigFile
else HscSource
HsSrcFile
, nms_location :: ModLocation
nms_location = ModLocation
location
, nms_mod :: Module
nms_mod = Module
mod
, nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
}
checkSummaryHash
:: HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary -> ModLocation -> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash :: forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash
HscEnv
hsc_env Fingerprint -> IO (Either e ModSummary)
new_summary
ModSummary
old_summary
ModLocation
location Fingerprint
src_hash
| ModSummary -> Fingerprint
ms_hs_hash ModSummary
old_summary forall a. Eq a => a -> a -> Bool
== Fingerprint
src_hash Bool -> Bool -> Bool
&&
Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = do
Maybe UTCTime
obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
location)
()
_ <- do
let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
case ModSummary -> HscSource
ms_hsc_src ModSummary
old_summary of
HscSource
HsSrcFile -> FinderCache -> Module -> ModLocation -> IO ()
addModuleToFinder FinderCache
fc (ModSummary -> Module
ms_mod ModSummary
old_summary) ModLocation
location
HscSource
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe UTCTime
hi_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
location)
Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
location)
return $ forall a b. b -> Either a b
Right
( ModSummary
old_summary
{ ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
, ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
, ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
}
)
| Bool
otherwise =
Fingerprint -> IO (Either e ModSummary)
new_summary Fingerprint
src_hash
data SummariseResult =
FoundInstantiation InstantiatedUnit
| FoundHomeWithError (UnitId, DriverMessages)
| FoundHome ModSummary
| External UnitId
| NotThere
summariseModule
:: HscEnv
-> HomeUnit
-> M.Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> Located ModuleName
-> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule :: HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env' HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
is_boot (L SrcSpan
_ ModuleName
wanted_mod) PkgQual
mb_pkg
Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
| ModuleName
wanted_mod forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
excl_mods
= forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
| Bool
otherwise = IO SummariseResult
find_it
where
hsc_env :: HscEnv
hsc_env = HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
find_it :: IO SummariseResult
find_it :: IO SummariseResult
find_it = do
FindResult
found <- HscEnv -> ModuleName -> PkgQual -> IO FindResult
findImportedModule HscEnv
hsc_env ModuleName
wanted_mod PkgQual
mb_pkg
case FindResult
found of
Found ModLocation
location Module
mod
| forall a. Maybe a -> Bool
isJust (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location) ->
ModLocation -> Module -> IO SummariseResult
just_found ModLocation
location Module
mod
| VirtUnit InstantiatedUnit
iud <- forall unit. GenModule unit -> unit
moduleUnit Module
mod
, Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod)
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> SummariseResult
FoundInstantiation InstantiatedUnit
iud
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UnitId -> SummariseResult
External (Module -> UnitId
moduleUnitId Module
mod)
FindResult
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
just_found :: ModLocation -> Module -> IO SummariseResult
just_found ModLocation
location Module
mod = do
let location' :: ModLocation
location' = case IsBootInterface
is_boot of
IsBootInterface
IsBoot -> ModLocation -> ModLocation
addBootSuffixLocn ModLocation
location
IsBootInterface
NotBoot -> ModLocation
location
src_fn :: FilePath
src_fn = forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"summarise2" (ModLocation -> Maybe FilePath
ml_hs_file ModLocation
location')
Maybe Fingerprint
maybe_h <- FilePath -> IO (Maybe Fingerprint)
fileHashIfExists FilePath
src_fn
case Maybe Fingerprint
maybe_h of
Maybe Fingerprint
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return SummariseResult
NotThere
Just Fingerprint
h -> do
Either DriverMessages ModSummary
fresult <- ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary_cache_check ModLocation
location' Module
mod FilePath
src_fn Fingerprint
h
return $ case Either DriverMessages ModSummary
fresult of
Left DriverMessages
err -> (UnitId, DriverMessages) -> SummariseResult
FoundHomeWithError (Module -> UnitId
moduleUnitId Module
mod, DriverMessages
err)
Right ModSummary
ms -> ModSummary -> SummariseResult
FoundHome ModSummary
ms
new_summary_cache_check :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary_cache_check ModLocation
loc Module
mod FilePath
src_fn Fingerprint
h
| Just ModSummary
old_summary <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((GenUnit UnitId -> UnitId
toUnitId (forall unit. GenModule unit -> unit
moduleUnit Module
mod), FilePath
src_fn)) Map (UnitId, FilePath) ModSummary
old_summary_map =
case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
Just (InputFileBuffer
buf,UTCTime
_) ->
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash HscEnv
hsc_env (ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn) ModSummary
old_summary ModLocation
loc (InputFileBuffer -> Fingerprint
fingerprintStringBuffer InputFileBuffer
buf)
Maybe (InputFileBuffer, UTCTime)
Nothing ->
forall e.
HscEnv
-> (Fingerprint -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either e ModSummary)
checkSummaryHash HscEnv
hsc_env (ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn) ModSummary
old_summary ModLocation
loc Fingerprint
h
| Bool
otherwise = ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
loc Module
mod FilePath
src_fn Fingerprint
h
new_summary :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary :: ModLocation
-> Module
-> FilePath
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
new_summary ModLocation
location Module
mod FilePath
src_fn Fingerprint
src_hash
= forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
DynFlags
SrcSpan
InputFileBuffer
ModuleName
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_ghc_prim_import :: Bool
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..}
<- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
mod) HscEnv
hsc_env) FilePath
src_fn forall a. Maybe a
Nothing Maybe (InputFileBuffer, UTCTime)
maybe_buf
let hsc_src :: HscSource
hsc_src
| IsBootInterface
is_boot forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot = HscSource
HsBootFile
| FilePath -> Bool
isHaskellSigFilename FilePath
src_fn = HscSource
HsigFile
| Bool
otherwise = HscSource
HsSrcFile
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
pi_mod_name forall a. Eq a => a -> a -> Bool
/= ModuleName
wanted_mod) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> DriverMessage
DriverFileModuleNameMismatch ModuleName
pi_mod_name ModuleName
wanted_mod
let instantiations :: GenInstantiations UnitId
instantiations = forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name GenInstantiations UnitId
instantiations)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
forall a b. (a -> b) -> a -> b
$ ModuleName
-> BuildingCabalPackage
-> GenInstantiations UnitId
-> DriverMessage
DriverUnexpectedSignature ModuleName
pi_mod_name (DynFlags -> BuildingCabalPackage
checkBuildingCabalPackage DynFlags
dflags) GenInstantiations UnitId
instantiations
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
{ nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
, nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
, nms_is_boot :: IsBootInterface
nms_is_boot = IsBootInterface
is_boot
, nms_hsc_src :: HscSource
nms_hsc_src = HscSource
hsc_src
, nms_location :: ModLocation
nms_location = ModLocation
location
, nms_mod :: Module
nms_mod = Module
mod
, nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
}
data MakeNewModSummary
= MakeNewModSummary
{ MakeNewModSummary -> FilePath
nms_src_fn :: FilePath
, MakeNewModSummary -> Fingerprint
nms_src_hash :: Fingerprint
, MakeNewModSummary -> IsBootInterface
nms_is_boot :: IsBootInterface
, MakeNewModSummary -> HscSource
nms_hsc_src :: HscSource
, MakeNewModSummary -> ModLocation
nms_location :: ModLocation
, MakeNewModSummary -> Module
nms_mod :: Module
, MakeNewModSummary -> PreprocessedImports
nms_preimps :: PreprocessedImports
}
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env MakeNewModSummary{FilePath
Fingerprint
HscSource
ModLocation
Module
IsBootInterface
PreprocessedImports
nms_preimps :: PreprocessedImports
nms_mod :: Module
nms_location :: ModLocation
nms_hsc_src :: HscSource
nms_is_boot :: IsBootInterface
nms_src_hash :: Fingerprint
nms_src_fn :: FilePath
nms_preimps :: MakeNewModSummary -> PreprocessedImports
nms_mod :: MakeNewModSummary -> Module
nms_location :: MakeNewModSummary -> ModLocation
nms_hsc_src :: MakeNewModSummary -> HscSource
nms_is_boot :: MakeNewModSummary -> IsBootInterface
nms_src_hash :: MakeNewModSummary -> Fingerprint
nms_src_fn :: MakeNewModSummary -> FilePath
..} = do
let PreprocessedImports{Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
DynFlags
SrcSpan
InputFileBuffer
ModuleName
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_ghc_prim_import :: Bool
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> InputFileBuffer
pi_hspp_fn :: PreprocessedImports -> FilePath
pi_ghc_prim_import :: PreprocessedImports -> Bool
pi_theimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: PreprocessedImports -> DynFlags
..} = PreprocessedImports
nms_preimps
Maybe UTCTime
obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_obj_file ModLocation
nms_location)
Maybe UTCTime
dyn_obj_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_dyn_obj_file ModLocation
nms_location)
Maybe UTCTime
hi_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hi_file ModLocation
nms_location)
Maybe UTCTime
hie_timestamp <- FilePath -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> FilePath
ml_hie_file ModLocation
nms_location)
[ModuleName]
extra_sig_imports <- HscEnv -> HscSource -> ModuleName -> IO [ModuleName]
findExtraSigImports HscEnv
hsc_env HscSource
nms_hsc_src ModuleName
pi_mod_name
([ModuleName]
implicit_sigs, [InstantiatedUnit]
_inst_deps) <- HscEnv
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
nms_mod) HscEnv
hsc_env) [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps
return $
ModSummary
{ ms_mod :: Module
ms_mod = Module
nms_mod
, ms_hsc_src :: HscSource
ms_hsc_src = HscSource
nms_hsc_src
, ms_location :: ModLocation
ms_location = ModLocation
nms_location
, ms_hspp_file :: FilePath
ms_hspp_file = FilePath
pi_hspp_fn
, ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
pi_local_dflags
, ms_hspp_buf :: Maybe InputFileBuffer
ms_hspp_buf = forall a. a -> Maybe a
Just InputFileBuffer
pi_hspp_buf
, ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = forall a. Maybe a
Nothing
, ms_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_srcimps = [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps
, ms_ghc_prim_import :: Bool
ms_ghc_prim_import = Bool
pi_ghc_prim_import
, ms_textual_imps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_textual_imps =
((,) PkgQual
NoPkgQual forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
extra_sig_imports) forall a. [a] -> [a] -> [a]
++
((,) PkgQual
NoPkgQual forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Located e
noLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs) forall a. [a] -> [a] -> [a]
++
[(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps
, ms_hs_hash :: Fingerprint
ms_hs_hash = Fingerprint
nms_src_hash
, ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
, ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
, ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
, ms_dyn_obj_date :: Maybe UTCTime
ms_dyn_obj_date = Maybe UTCTime
dyn_obj_timestamp
}
data PreprocessedImports
= PreprocessedImports
{ PreprocessedImports -> DynFlags
pi_local_dflags :: DynFlags
, PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, Located ModuleName)]
, PreprocessedImports -> [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, Located ModuleName)]
, PreprocessedImports -> Bool
pi_ghc_prim_import :: Bool
, PreprocessedImports -> FilePath
pi_hspp_fn :: FilePath
, PreprocessedImports -> InputFileBuffer
pi_hspp_buf :: StringBuffer
, PreprocessedImports -> SrcSpan
pi_mod_name_loc :: SrcSpan
, PreprocessedImports -> ModuleName
pi_mod_name :: ModuleName
}
getPreprocessedImports
:: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports :: HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf = do
(DynFlags
pi_local_dflags, FilePath
pi_hspp_fn)
<- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> Maybe InputFileBuffer
-> Maybe Phase
-> IO (Either DriverMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
src_fn (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (InputFileBuffer, UTCTime)
maybe_buf) Maybe Phase
mb_phase
InputFileBuffer
pi_hspp_buf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO InputFileBuffer
hGetStringBuffer FilePath
pi_hspp_fn
([(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps', [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps', Bool
pi_ghc_prim_import, L SrcSpan
pi_mod_name_loc ModuleName
pi_mod_name)
<- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
let imp_prelude :: Bool
imp_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
pi_local_dflags
popts :: ParserOpts
popts = DynFlags -> ParserOpts
initParserOpts DynFlags
pi_local_dflags
Either
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
mimps <- ParserOpts
-> Bool
-> InputFileBuffer
-> FilePath
-> FilePath
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
getImports ParserOpts
popts Bool
imp_prelude InputFileBuffer
pi_hspp_buf FilePath
pi_hspp_fn FilePath
src_fn
return (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Messages e -> Bag (MsgEnvelope e)
getMessages) Either
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
mimps)
let rn_pkg_qual :: ModuleName -> RawPkgQual -> PkgQual
rn_pkg_qual = UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
renameRawPkgQual (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env)
let rn_imps :: [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RawPkgQual
pk, lmn :: GenLocated SrcSpan ModuleName
lmn@(L SrcSpan
_ ModuleName
mn)) -> (ModuleName -> RawPkgQual -> PkgQual
rn_pkg_qual ModuleName
mn RawPkgQual
pk, GenLocated SrcSpan ModuleName
lmn))
let pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps = [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps'
let pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps = [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
rn_imps [(RawPkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps'
forall (m :: * -> *) a. Monad m => a -> m a
return PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
DynFlags
SrcSpan
InputFileBuffer
ModuleName
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_ghc_prim_import :: Bool
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_local_dflags :: DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: InputFileBuffer
pi_hspp_fn :: FilePath
pi_ghc_prim_import :: Bool
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_local_dflags :: DynFlags
..}
withDeferredDiagnostics :: GhcMonad m => m a -> m a
withDeferredDiagnostics :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics m a
f = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DeferDiagnostics DynFlags
dflags
then m a
f
else do
IORef [IO ()]
warnings <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
IORef [IO ()]
errors <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
IORef [IO ()]
fatals <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
let deferDiagnostics :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
deferDiagnostics LogFlags
_dflags !MessageClass
msgClass !SrcSpan
srcSpan !SDoc
msg = do
let action :: IO ()
action = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
msgClass SrcSpan
srcSpan SDoc
msg
case MessageClass
msgClass of
MCDiagnostic Severity
SevWarning DiagnosticReason
_reason Maybe DiagnosticCode
_code
-> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
warnings forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
MCDiagnostic Severity
SevError DiagnosticReason
_reason Maybe DiagnosticCode
_code
-> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
errors forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
MessageClass
MCFatal
-> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
fatals forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> (IO ()
actionforall a. a -> [a] -> [a]
: [IO ()]
i, ())
MessageClass
_ -> IO ()
action
printDeferredDiagnostics :: m ()
printDeferredDiagnostics = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IORef [IO ()]
warnings, IORef [IO ()]
errors, IORef [IO ()]
fatals] forall a b. (a -> b) -> a -> b
$ \IORef [IO ()]
ref -> do
[IO ()]
actions <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
ref forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> ([], [IO ()]
i)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [IO ()]
actions
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
(forall (m :: * -> *).
GhcMonad m =>
((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
pushLogHookM (forall a b. a -> b -> a
const LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
deferDiagnostics))
(\()
_ -> forall (m :: * -> *). GhcMonad m => m ()
popLogHookM forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
printDeferredDiagnostics)
(\()
_ -> m a
f)
noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
noModError :: HscEnv
-> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
noModError HscEnv
hsc_env SrcSpan
loc ModuleName
wanted_mod FindResult
err
= forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$
UnknownDiagnostic -> DriverMessage
DriverUnknownMessage forall a b. (a -> b) -> a -> b
$ forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
wanted_mod FindResult
err
moduleNotFoundErr :: ModuleName -> DriverMessages
moduleNotFoundErr :: ModuleName -> DriverMessages
moduleNotFoundErr ModuleName
mod = forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverModuleNotFound ModuleName
mod)
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = forall a. HasCallStack => FilePath -> a
panic FilePath
"multiRootsErr"
multiRootsErr summs :: [ModSummary]
summs@(ModSummary
summ1:[ModSummary]
_)
= forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$ Module -> [FilePath] -> DriverMessage
DriverDuplicatedModuleDeclaration Module
mod [FilePath]
files
where
mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
summ1
files :: [FilePath]
files = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"checkDup" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModLocation -> Maybe FilePath
ml_hs_file forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location) [ModSummary]
summs
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr :: [ModuleGraphNode] -> SDoc
cyclicModuleErr [ModuleGraphNode]
mss
= forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleGraphNode]
mss)) forall a b. (a -> b) -> a -> b
$
case forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node NodeKey ModuleGraphNode]
graph of
Maybe [ModuleGraphNode]
Nothing -> forall doc. IsLine doc => FilePath -> doc
text FilePath
"Unexpected non-cycle" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mss
Just [ModuleGraphNode]
path0 -> forall doc. IsDoc doc => [doc] -> doc
vcat
[ forall doc. IsLine doc => FilePath -> doc
text FilePath
"Module graph contains a cycle:"
, Int -> SDoc -> SDoc
nest Int
2 ([ModuleGraphNode] -> SDoc
show_path [ModuleGraphNode]
path0)]
where
graph :: [Node NodeKey ModuleGraphNode]
graph :: [Node NodeKey ModuleGraphNode]
graph =
[ DigraphNode
{ node_payload :: ModuleGraphNode
node_payload = ModuleGraphNode
ms
, node_key :: NodeKey
node_key = ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
ms
, node_dependencies :: [NodeKey]
node_dependencies = Bool -> ModuleGraphNode -> [NodeKey]
nodeDependencies Bool
False ModuleGraphNode
ms
}
| ModuleGraphNode
ms <- [ModuleGraphNode]
mss
]
show_path :: [ModuleGraphNode] -> SDoc
show_path :: [ModuleGraphNode] -> SDoc
show_path [] = forall a. HasCallStack => FilePath -> a
panic FilePath
"show_path"
show_path [ModuleGraphNode
m] = ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
"imports itself"
show_path (ModuleGraphNode
m1:ModuleGraphNode
m2:[ModuleGraphNode]
ms) = forall doc. IsDoc doc => [doc] -> doc
vcat ( Int -> SDoc -> SDoc
nest Int
6 (ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1)
forall a. a -> [a] -> [a]
: Int -> SDoc -> SDoc
nest Int
6 (forall doc. IsLine doc => FilePath -> doc
text FilePath
"imports" forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m2)
forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> [SDoc]
go [ModuleGraphNode]
ms )
where
go :: [ModuleGraphNode] -> [SDoc]
go [] = [forall doc. IsLine doc => FilePath -> doc
text FilePath
"which imports" forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m1]
go (ModuleGraphNode
m:[ModuleGraphNode]
ms) = (forall doc. IsLine doc => FilePath -> doc
text FilePath
"which imports" forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleGraphNode -> SDoc
ppr_node ModuleGraphNode
m) forall a. a -> [a] -> [a]
: [ModuleGraphNode] -> [SDoc]
go [ModuleGraphNode]
ms
ppr_node :: ModuleGraphNode -> SDoc
ppr_node :: ModuleGraphNode -> SDoc
ppr_node (ModuleNode [NodeKey]
_deps ModSummary
m) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"module" forall doc. IsLine doc => doc -> doc -> doc
<+> ModSummary -> SDoc
ppr_ms ModSummary
m
ppr_node (InstantiationNode UnitId
_uid InstantiatedUnit
u) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"instantiated unit" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
u
ppr_node (LinkNode [NodeKey]
uid UnitId
_) = forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"LinkNode should not be in a cycle" (forall a. Outputable a => a -> SDoc
ppr [NodeKey]
uid)
ppr_ms :: ModSummary -> SDoc
ppr_ms :: ModSummary -> SDoc
ppr_ms ModSummary
ms = SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
ms))) forall doc. IsLine doc => doc -> doc -> doc
<+>
(forall doc. IsLine doc => doc -> doc
parens (forall doc. IsLine doc => FilePath -> doc
text (ModSummary -> FilePath
msHsFilePath ModSummary
ms)))
cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe :: forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe Logger
logger TmpFs
tmpfs DynFlags
dflags =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TmpFs -> IO ()
cleanCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv [HomeModInfo]
deps HscEnv
hsc_env =
(HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG (\HomeUnitGraph
hug -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeModInfo -> HomeUnitGraph -> HomeUnitGraph
addHomeModInfoToHug HomeUnitGraph
hug [HomeModInfo]
deps) HscEnv
hsc_env
setHPT :: HomePackageTable -> HscEnv -> HscEnv
setHPT :: HomePackageTable -> HscEnv -> HscEnv
setHPT HomePackageTable
deps HscEnv
hsc_env =
(HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ HomePackageTable
deps) HscEnv
hsc_env
setHUG :: HomeUnitGraph -> HscEnv -> HscEnv
setHUG :: HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
deps HscEnv
hsc_env =
(HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
hscUpdateHUG (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ HomeUnitGraph
deps) HscEnv
hsc_env
wrapAction :: HscEnv -> IO a -> IO (Maybe a)
wrapAction :: forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction HscEnv
hsc_env IO a
k = do
let lcl_logger :: Logger
lcl_logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
lcl_dynflags :: DynFlags
lcl_dynflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
lcl_dynflags
let logg :: SourceError -> IO ()
logg SourceError
err = forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
lcl_logger DiagnosticOpts GhcMessage
print_config (DynFlags -> DiagOpts
initDiagOpts DynFlags
lcl_dynflags) (SourceError -> Messages GhcMessage
srcErrorMessages SourceError
err)
Either SomeException a
mres <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ExceptionMonad m => Logger -> m a -> m a
prettyPrintGhcErrors Logger
lcl_logger forall a b. (a -> b) -> a -> b
$ IO a
k
case Either SomeException a
mres of
Right a
res -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
res
Left SomeException
exc -> do
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just (SourceError
err :: SourceError)
-> SourceError -> IO ()
logg SourceError
err
Maybe SourceError
Nothing -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just (SomeAsyncException
err :: SomeAsyncException) -> forall e a. Exception e => e -> IO a
throwIO SomeAsyncException
err
Maybe SomeAsyncException
_ -> Logger -> SDoc -> IO ()
errorMsg Logger
lcl_logger (forall doc. IsLine doc => FilePath -> doc
text (forall a. Show a => a -> FilePath
show SomeException
exc))
return forall a. Maybe a
Nothing
withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog :: forall b.
TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog TVar LogQueueQueue
lqq_var Int
k (Logger -> Logger) -> IO b
cont = do
let init_log :: IO LogQueue
init_log = do
LogQueue
lq <- Int -> IO LogQueue
newLogQueue Int
k
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ TVar LogQueueQueue -> LogQueue -> STM ()
initLogQueue TVar LogQueueQueue
lqq_var LogQueue
lq
return LogQueue
lq
finish_log :: LogQueue -> m ()
finish_log LogQueue
lq = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LogQueue -> IO ()
finishLogQueue LogQueue
lq)
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO LogQueue
init_log forall {m :: * -> *}. MonadIO m => LogQueue -> m ()
finish_log forall a b. (a -> b) -> a -> b
$ \LogQueue
lq -> (Logger -> Logger) -> IO b
cont (((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> Logger -> Logger
pushLogHook (forall a b. a -> b -> a
const (LogQueue -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
parLogAction LogQueue
lq)))
withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc :: forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv{forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger, HscEnv
hsc_env :: HscEnv
hsc_env :: MakeEnv -> HscEnv
hsc_env} HscEnv -> IO a
cont = do
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger Int
k forall a b. (a -> b) -> a -> b
$ \Logger -> Logger
modifyLogger -> do
let lcl_logger :: Logger
lcl_logger = Logger -> Logger
modifyLogger (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env { hsc_logger :: Logger
hsc_logger = Logger
lcl_logger }
HscEnv -> IO a
cont HscEnv
hsc_env'
executeInstantiationNode :: Int
-> Int
-> HomeUnitGraph
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode :: Int
-> Int
-> HomeUnitGraph
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode Int
k Int
n HomeUnitGraph
deps UnitId
uid InstantiatedUnit
iu = do
MakeEnv
env <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Maybe Messager
msg <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> Maybe Messager
env_messager
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
env forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
let lcl_hsc_env :: HscEnv
lcl_hsc_env = HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
deps HscEnv
hsc_env
in forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction HscEnv
lcl_hsc_env forall a b. (a -> b) -> a -> b
$ do
()
res <- HscEnv
-> Maybe Messager
-> Int
-> Int
-> UnitId
-> InstantiatedUnit
-> IO ()
upsweep_inst HscEnv
lcl_hsc_env Maybe Messager
msg Int
k Int
n UnitId
uid InstantiatedUnit
iu
forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env) (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
return ()
res
executeCompileNode :: Int
-> Int
-> Maybe HomeModInfo
-> HomeUnitGraph
-> Maybe [ModuleName]
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode :: Int
-> Int
-> Maybe HomeModInfo
-> HomeUnitGraph
-> Maybe [ModuleName]
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode Int
k Int
n !Maybe HomeModInfo
old_hmi HomeUnitGraph
hug Maybe [ModuleName]
mrehydrate_mods ModSummary
mod = do
me :: MakeEnv
me@MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: AbstractSem
hsc_env :: HscEnv
env_messager :: MakeEnv -> Maybe Messager
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: MakeEnv -> AbstractSem
hsc_env :: MakeEnv -> HscEnv
..} <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem forall a b. (a -> b) -> a -> b
$ forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
me forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
HscEnv
hydrated_hsc_env <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore (HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
hug HscEnv
hsc_env) ModSummary
mod Maybe [ModuleName]
fixed_mrehydrate_mods
let
lcl_dynflags :: DynFlags
lcl_dynflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
mod
let lcl_hsc_env :: HscEnv
lcl_hsc_env =
HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
lcl_dynflags forall a b. (a -> b) -> a -> b
$
HscEnv
hydrated_hsc_env
forall a. HscEnv -> IO a -> IO (Maybe a)
wrapAction HscEnv
lcl_hsc_env forall a b. (a -> b) -> a -> b
$ do
HomeModInfo
res <- HscEnv
-> Maybe Messager
-> Maybe HomeModInfo
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
lcl_hsc_env Maybe Messager
env_messager Maybe HomeModInfo
old_hmi ModSummary
mod Int
k Int
n
forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env) DynFlags
lcl_dynflags
return HomeModInfo
res)
where
fixed_mrehydrate_mods :: Maybe [ModuleName]
fixed_mrehydrate_mods =
case ModSummary -> HscSource
ms_hsc_src ModSummary
mod of
HscSource
HsigFile -> forall a. a -> Maybe a
Just []
HscSource
_ -> Maybe [ModuleName]
mrehydrate_mods
rehydrate :: HscEnv
-> [HomeModInfo]
-> IO HscEnv
rehydrate :: HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate HscEnv
hsc_env [HomeModInfo]
hmis = do
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 forall a b. (a -> b) -> a -> b
$ (
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Re-hydrating loop: " forall doc. IsLine doc => doc -> doc -> doc
<+> (forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis)))
[(ModuleName, HomeModInfo)]
new_mods <- forall a. (a -> IO a) -> IO a
fixIO forall a b. (a -> b) -> a -> b
$ \[(ModuleName, HomeModInfo)]
new_mods -> do
let new_hpt :: HomePackageTable
new_hpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt HomePackageTable
old_hpt [(ModuleName, HomeModInfo)]
new_mods
let new_hsc_env :: HscEnv
new_hsc_env = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT_lazy (forall a b. a -> b -> a
const HomePackageTable
new_hpt) HscEnv
hsc_env
[ModDetails]
mds <- forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (forall doc. IsLine doc => FilePath -> doc
text FilePath
"rehydrate") HscEnv
new_hsc_env forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
let new_mods :: [(ModuleName, HomeModInfo)]
new_mods = [ (ModuleName
mn,HomeModInfo
hmi{ hm_details :: ModDetails
hm_details = ModDetails
details })
| (HomeModInfo
hmi,ModDetails
details) <- forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds
, let mn :: ModuleName
mn = forall unit. GenModule unit -> ModuleName
moduleName (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)) ]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ModuleName, HomeModInfo)]
new_mods
return $ HomePackageTable -> HscEnv -> HscEnv
setHPT (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\HomePackageTable
old (ModuleName
mn, HomeModInfo
hmi) -> HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
old ModuleName
mn HomeModInfo
hmi) HomePackageTable
old_hpt [(ModuleName, HomeModInfo)]
new_mods) HscEnv
hsc_env
where
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
to_delete :: [ModuleName]
to_delete = (forall a b. (a -> b) -> [a] -> [b]
map (forall unit. GenModule unit -> ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis)
!old_hpt :: HomePackageTable
old_hpt = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) [ModuleName]
to_delete
maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore HscEnv
hsc_env ModSummary
_ Maybe [ModuleName]
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
maybeRehydrateBefore HscEnv
hsc_env ModSummary
mod (Just [ModuleName]
mns) = do
ModuleEnv (IORef TypeEnv)
knot_var <- HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env
let hmis :: [HomeModInfo]
hmis = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"mr" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)) [ModuleName]
mns
HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate (HscEnv
hsc_env { hsc_type_env_vars :: KnotVars (IORef TypeEnv)
hsc_type_env_vars = forall a. ModuleEnv a -> KnotVars a
knotVarsFromModuleEnv ModuleEnv (IORef TypeEnv)
knot_var }) [HomeModInfo]
hmis
where
initialise_knot_var :: HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
let mod_name :: Module
mod_name = Maybe HomeUnit -> Module -> Module
homeModuleInstantiation (HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env) (ModSummary -> Module
ms_mod ModSummary
mod)
in forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module
mod_name,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef TypeEnv
emptyTypeEnv
rehydrateAfter :: HscEnv
-> [ModuleName]
-> IO [HomeModInfo]
rehydrateAfter :: HscEnv -> [ModuleName] -> IO [HomeModInfo]
rehydrateAfter HscEnv
new_hsc [ModuleName]
mns = do
let new_hpt :: HomePackageTable
new_hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
new_hsc
hmis :: [HomeModInfo]
hmis = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"mrAfter" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
new_hpt) [ModuleName]
mns
HscEnv
hsc_env <- HscEnv -> [HomeModInfo] -> IO HscEnv
rehydrate (HscEnv
new_hsc { hsc_type_env_vars :: KnotVars (IORef TypeEnv)
hsc_type_env_vars = forall a. KnotVars a
emptyKnotVars }) [HomeModInfo]
hmis
return $ forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
mn -> forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"rehydrate" forall a b. (a -> b) -> a -> b
$ HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env) ModuleName
mn) [ModuleName]
mns
executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
executeLinkNode HomeUnitGraph
hug (Int, Int)
kn UnitId
uid [NodeKey]
deps = do
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
uid forall a b. (a -> b) -> a -> b
$ do
MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: AbstractSem
hsc_env :: HscEnv
env_messager :: MakeEnv -> Maybe Messager
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: MakeEnv -> AbstractSem
hsc_env :: MakeEnv -> HscEnv
..} <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let hsc_env' :: HscEnv
hsc_env' = HomeUnitGraph -> HscEnv -> HscEnv
setHUG HomeUnitGraph
hug HscEnv
hsc_env
msg' :: Maybe (RecompileRequired -> IO ())
msg' = (\Messager
messager -> \RecompileRequired
recomp -> Messager
messager HscEnv
hsc_env (Int, Int)
kn RecompileRequired
recomp ([NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
deps UnitId
uid)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Messager
env_messager
SuccessFlag
linkresult <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem forall a b. (a -> b) -> a -> b
$ do
GhcLink
-> Logger
-> TmpFs
-> Hooks
-> DynFlags
-> UnitEnv
-> Bool
-> Maybe (RecompileRequired -> IO ())
-> HomePackageTable
-> IO SuccessFlag
link (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
(HscEnv -> Logger
hsc_logger HscEnv
hsc_env')
(HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env')
(HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env')
DynFlags
dflags
(HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env')
Bool
True
Maybe (RecompileRequired -> IO ())
msg'
(HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env')
case SuccessFlag
linkresult of
SuccessFlag
Failed -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Link Failed"
SuccessFlag
Succeeded -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
type ModuleNameSet = M.Map UnitId I.IntSet
addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet UnitId
uid ModuleName
mn ModuleNameSet
s =
let k :: Int
k = (Unique -> Int
getKey forall a b. (a -> b) -> a -> b
$ forall a. Uniquable a => a -> Unique
getUnique forall a b. (a -> b) -> a -> b
$ ModuleName
mn)
in forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (IntSet -> IntSet -> IntSet
I.union) UnitId
uid (Int -> IntSet
I.singleton Int
k) ModuleNameSet
s
wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
wait_deps_hug :: MVar HomeUnitGraph
-> [BuildResult]
-> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
wait_deps_hug MVar HomeUnitGraph
hug_var [BuildResult]
deps = do
([HomeModInfo]
_, ModuleNameSet
module_deps) <- [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps [BuildResult]
deps
HomeUnitGraph
hug <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
readMVar MVar HomeUnitGraph
hug_var
let pruneHomeUnitEnv :: UnitId -> HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv UnitId
uid HomeUnitEnv
hme =
let
!new :: HomePackageTable
new = forall key elt. UniqDFM key elt -> IntSet -> UniqDFM key elt
udfmRestrictKeysSet (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hme) (forall a. a -> Maybe a -> a
fromMaybe IntSet
I.empty forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UnitId
uid ModuleNameSet
module_deps)
in HomeUnitEnv
hme { homeUnitEnv_hpt :: HomePackageTable
homeUnitEnv_hpt = HomePackageTable
new }
forall (m :: * -> *) a. Monad m => a -> m a
return (forall v b. (UnitId -> v -> b) -> UnitEnvGraph v -> UnitEnvGraph b
unitEnv_mapWithKey UnitId -> HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv HomeUnitGraph
hug, ModuleNameSet
module_deps)
wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall k a. Map k a
M.empty)
wait_deps (BuildResult
x:[BuildResult]
xs) = do
(Maybe HomeModInfo
res, ModuleNameSet
deps) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. ResultVar a -> MaybeT IO a
waitResult (BuildResult -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
resultVar BuildResult
x)
([HomeModInfo]
hmis, ModuleNameSet
all_deps) <- [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps [BuildResult]
xs
let !new_deps :: ModuleNameSet
new_deps = ModuleNameSet
deps ModuleNameSet -> ModuleNameSet -> ModuleNameSet
`unionModuleNameSet` ModuleNameSet
all_deps
case Maybe HomeModInfo
res of
Maybe HomeModInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ([HomeModInfo]
hmis, ModuleNameSet
new_deps)
Just HomeModInfo
hmi -> forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo
hmiforall a. a -> [a] -> [a]
:[HomeModInfo]
hmis, ModuleNameSet
new_deps)
where
unionModuleNameSet :: ModuleNameSet -> ModuleNameSet -> ModuleNameSet
unionModuleNameSet = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith IntSet -> IntSet -> IntSet
I.union
label_self :: String -> IO ()
label_self :: FilePath -> IO ()
label_self FilePath
thread_name = do
ThreadId
self_tid <- IO ThreadId
CC.myThreadId
ThreadId -> FilePath -> IO ()
CC.labelThread ThreadId
self_tid FilePath
thread_name
runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines Int
_ HscEnv
_ Maybe Messager
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
runPipelines Int
n_job HscEnv
hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self FilePath
"main --make thread"
case Int
n_job of
Int
1 -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines HscEnv
hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines
Int
_n -> Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runParPipelines Int
n_job HscEnv
hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines
runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines HscEnv
plugin_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines =
let env :: MakeEnv
env = MakeEnv { hsc_env :: HscEnv
hsc_env = HscEnv
plugin_hsc_env
, withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger = \Int
_ (Logger -> Logger) -> IO a
k -> (Logger -> Logger) -> IO a
k forall a. a -> a
id
, compile_sem :: AbstractSem
compile_sem = IO () -> IO () -> AbstractSem
AbstractSem (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. Monad m => a -> m a
return ())
, env_messager :: Maybe Messager
env_messager = Maybe Messager
mHscMessager
}
in Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
1 MakeEnv
env [MakeAction]
all_pipelines
runParPipelines :: Int
-> HscEnv
-> Maybe Messager
-> [MakeAction]
-> IO ()
runParPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
runParPipelines Int
n_jobs HscEnv
plugin_hsc_env Maybe Messager
mHscMessager [MakeAction]
all_pipelines = do
TVar Bool
stopped_var <- forall a. a -> IO (TVar a)
newTVarIO Bool
False
TVar LogQueueQueue
log_queue_queue_var <- forall a. a -> IO (TVar a)
newTVarIO LogQueueQueue
newLogQueueQueue
IO ()
wait_log_thread <- Int
-> Int -> Logger -> TVar Bool -> TVar LogQueueQueue -> IO (IO ())
logThread Int
n_jobs (forall (t :: * -> *) a. Foldable t => t a -> Int
length [MakeAction]
all_pipelines) (HscEnv -> Logger
hsc_logger HscEnv
plugin_hsc_env) TVar Bool
stopped_var TVar LogQueueQueue
log_queue_queue_var
Logger
thread_safe_logger <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> IO Logger
makeThreadSafe (HscEnv -> Logger
hsc_logger HscEnv
plugin_hsc_env)
let thread_safe_hsc_env :: HscEnv
thread_safe_hsc_env = HscEnv
plugin_hsc_env { hsc_logger :: Logger
hsc_logger = Logger
thread_safe_logger }
let updNumCapabilities :: IO Int
updNumCapabilities = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Int
n_capabilities <- IO Int
getNumCapabilities
Int
n_cpus <- IO Int
getNumProcessors
let n_caps :: Int
n_caps = forall a. Ord a => a -> a -> a
min Int
n_jobs Int
n_cpus
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n_capabilities forall a. Eq a => a -> a -> Bool
/= Int
1) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n_caps
return Int
n_capabilities
let resetNumCapabilities :: Int -> IO ()
resetNumCapabilities Int
orig_n = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
orig_n
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
stopped_var Bool
True
IO ()
wait_log_thread
QSem
compile_sem <- Int -> IO QSem
newQSem Int
n_jobs
let abstract_sem :: AbstractSem
abstract_sem = IO () -> IO () -> AbstractSem
AbstractSem (QSem -> IO ()
waitQSem QSem
compile_sem) (QSem -> IO ()
signalQSem QSem
compile_sem)
let env :: MakeEnv
env = MakeEnv { hsc_env :: HscEnv
hsc_env = HscEnv
thread_safe_hsc_env
, withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger = forall b.
TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog TVar LogQueueQueue
log_queue_queue_var
, compile_sem :: AbstractSem
compile_sem = AbstractSem
abstract_sem
, env_messager :: Maybe Messager
env_messager = Maybe Messager
mHscMessager
}
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO Int
updNumCapabilities Int -> IO ()
resetNumCapabilities forall a b. (a -> b) -> a -> b
$ \Int
_ ->
Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
n_jobs MakeEnv
env [MakeAction]
all_pipelines
withLocalTmpFS :: RunMakeM a -> RunMakeM a
withLocalTmpFS :: forall a. RunMakeM a -> RunMakeM a
withLocalTmpFS RunMakeM a
act = do
let initialiser :: ReaderT MakeEnv (MaybeT IO) HscEnv
initialiser = do
MakeEnv{Maybe Messager
HscEnv
AbstractSem
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: AbstractSem
hsc_env :: HscEnv
env_messager :: MakeEnv -> Maybe Messager
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
compile_sem :: MakeEnv -> AbstractSem
hsc_env :: MakeEnv -> HscEnv
..} <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
TmpFs
lcl_tmpfs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TmpFs -> IO TmpFs
forkTmpFsFrom (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
return $ HscEnv
hsc_env { hsc_tmpfs :: TmpFs
hsc_tmpfs = TmpFs
lcl_tmpfs }
finaliser :: HscEnv -> ReaderT MakeEnv m ()
finaliser HscEnv
lcl_env = do
MakeEnv
gbl_env <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ TmpFs -> TmpFs -> IO ()
mergeTmpFsInto (HscEnv -> TmpFs
hsc_tmpfs HscEnv
lcl_env) (HscEnv -> TmpFs
hsc_tmpfs (MakeEnv -> HscEnv
hsc_env MakeEnv
gbl_env))
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket ReaderT MakeEnv (MaybeT IO) HscEnv
initialiser forall {m :: * -> *}. MonadIO m => HscEnv -> ReaderT MakeEnv m ()
finaliser forall a b. (a -> b) -> a -> b
$ \HscEnv
lcl_hsc_env -> forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\MakeEnv
env -> MakeEnv
env { hsc_env :: HscEnv
hsc_env = HscEnv
lcl_hsc_env}) RunMakeM a
act
runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines Int
n_jobs MakeEnv
env [MakeAction]
acts = do
let spawn_actions :: IO [ThreadId]
spawn_actions :: IO [ThreadId]
spawn_actions = if Int
n_jobs forall a. Eq a => a -> a -> Bool
== Int
1
then (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop (\(forall a. IO a -> IO a) -> IO ()
io -> (forall a. IO a -> IO a) -> IO ()
io forall a. IO a -> IO a
unmask) MakeEnv
env [MakeAction]
acts)
else forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask MakeEnv
env [MakeAction]
acts
kill_actions :: [ThreadId] -> IO ()
kill_actions :: [ThreadId] -> IO ()
kill_actions [ThreadId]
tids = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId]
tids
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO [ThreadId]
spawn_actions [ThreadId] -> IO ()
kill_actions forall a b. (a -> b) -> a -> b
$ \[ThreadId]
_ -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MakeAction -> IO ()
waitMakeAction [MakeAction]
acts
runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]
runLoop :: forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
_ MakeEnv
_env [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread MakeEnv
env (MakeAction RunMakeM a
act MVar (Maybe a)
res_var :[MakeAction]
acts) = do
a
new_thread <-
((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> (do
Maybe a
mres <- (forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall a. RunMakeM a -> IO (Maybe a)
run_pipeline (forall a. RunMakeM a -> RunMakeM a
withLocalTmpFS RunMakeM a
act))
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`MC.onException` (forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
res_var forall a. Maybe a
Nothing)
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
res_var Maybe a
mres)
[a]
threads <- forall a.
(((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
runLoop ((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread MakeEnv
env [MakeAction]
acts
return (a
new_thread forall a. a -> [a] -> [a]
: [a]
threads)
where
run_pipeline :: RunMakeM a -> IO (Maybe a)
run_pipeline :: forall a. RunMakeM a -> IO (Maybe a)
run_pipeline RunMakeM a
p = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RunMakeM a
p MakeEnv
env)
data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))
waitMakeAction :: MakeAction -> IO ()
waitMakeAction :: MakeAction -> IO ()
waitMakeAction (MakeAction RunMakeM a
_ MVar (Maybe a)
mvar) = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. MVar a -> IO a
readMVar MVar (Maybe a)
mvar