{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
module GHC.Driver.Make (
depanal, depanalE, depanalPartial, checkHomeUnitsClosed,
load, loadWithCache, load', AnyGhcDiagnostic, 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.DynFlags (ReexportedModule(..))
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.Driver.MakeSem
import GHC.Parser.Header
import GHC.ByteCode.Types
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.OsPath ( unsafeEncodeUtf )
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.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.Unique.Map
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.List (sortOn, unfoldr)
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 GHC.Types.Unique
import GHC.Iface.Errors.Types
import qualified GHC.Data.Word64Set as W
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) <- (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE GhcMessage -> AnyGhcDiagnostic
forall a.
(Typeable a, Diagnostic a) =>
a -> UnknownDiagnostic (DiagnosticOpts a)
mkUnknownDiagnostic Maybe Messager
forall a. Maybe a
Nothing [ModuleName]
excluded_mods Bool
allow_dup_roots
if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then ModuleGraph -> m ModuleGraph
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleGraph
mod_graph
else Messages GhcMessage -> m ModuleGraph
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors ((DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage DriverMessages
errs)
depanalE :: GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE :: forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [ModuleName]
excluded_mods Bool
allow_dup_roots = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
(DriverMessages
errs, ModuleGraph
mod_graph) <- (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalPartial GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [ModuleName]
excluded_mods Bool
allow_dup_roots
if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then do
HscEnv
hsc_env <- m HscEnv
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
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 DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_home_mod_err
DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unused_pkg_err
DriverMessages -> DriverMessages -> DriverMessages
forall e. Messages e -> Messages e -> Messages e
`unionMessages` DriverMessages
unknown_module_err
DriverMessages
all_errs <- IO DriverMessages -> m DriverMessages
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DriverMessages -> m DriverMessages)
-> IO DriverMessages -> m DriverMessages
forall a b. (a -> b) -> a -> b
$ (IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages)
-> IO DriverMessages
-> UnitEnvGraph HomeUnitEnv
-> IO DriverMessages
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey IO DriverMessages -> UnitId -> HomeUnitEnv -> IO DriverMessages
one_unit_messages (DriverMessages -> IO DriverMessages
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DriverMessages
forall e. Messages e
emptyMessages) (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env)
Messages GhcMessage -> m ()
forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DriverMessages
all_errs)
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph = mod_graph }
pure (DriverMessages
forall e. Messages e
emptyMessages, ModuleGraph
mod_graph)
else do
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph = emptyMG }
pure (DriverMessages
errs, ModuleGraph
emptyMG)
depanalPartial
:: GhcMonad m
=> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalPartial :: forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalPartial GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [ModuleName]
excluded_mods Bool
allow_dup_roots = do
HscEnv
hsc_env <- m HscEnv
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
Logger
-> SDoc
-> ((DriverMessages, ModuleGraph) -> ())
-> m (DriverMessages, ModuleGraph)
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Chasing dependencies") (() -> (DriverMessages, ModuleGraph) -> ()
forall a b. a -> b -> a
const ()) (m (DriverMessages, ModuleGraph)
-> m (DriverMessages, ModuleGraph))
-> m (DriverMessages, ModuleGraph)
-> m (DriverMessages, ModuleGraph)
forall a b. (a -> b) -> a -> b
$ do
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Chasing modules from: ",
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ((Target -> SDoc) -> [Target] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Target -> SDoc
pprTarget [Target]
targets))])
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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) <- IO ([DriverMessages], [ModuleGraphNode])
-> m ([DriverMessages], [ModuleGraphNode])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([DriverMessages], [ModuleGraphNode])
-> m ([DriverMessages], [ModuleGraphNode]))
-> IO ([DriverMessages], [ModuleGraphNode])
-> m ([DriverMessages], [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep
HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg (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 ([DriverMessages] -> DriverMessages
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 (InstantiatedUnit -> ModuleGraphNode)
-> [InstantiatedUnit] -> [ModuleGraphNode]
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 =
[InstantiatedUnit] -> [InstantiatedUnit]
forall a. Ord a => [a] -> [a]
nubSort ([InstantiatedUnit] -> [InstantiatedUnit])
-> [InstantiatedUnit] -> [InstantiatedUnit]
forall a b. (a -> b) -> a -> b
$ ((GenUnit UnitId, Maybe PackageArg) -> [InstantiatedUnit])
-> [(GenUnit UnitId, Maybe PackageArg)] -> [InstantiatedUnit]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GenUnit UnitId -> [InstantiatedUnit]
forall {unit}. GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId (GenUnit UnitId -> [InstantiatedUnit])
-> ((GenUnit UnitId, Maybe PackageArg) -> GenUnit UnitId)
-> (GenUnit UnitId, Maybe PackageArg)
-> [InstantiatedUnit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenUnit UnitId, Maybe PackageArg) -> GenUnit UnitId
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 <- GenInstantiatedUnit unit -> GenInstantiations unit
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit unit
indef
, GenInstantiatedUnit unit
recur <- (GenInstantiatedUnit unit
indef GenInstantiatedUnit unit
-> [GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit]
forall a. a -> [a] -> [a]
:) ([GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit])
-> [GenInstantiatedUnit unit] -> [GenInstantiatedUnit unit]
forall a b. (a -> b) -> a -> b
$ GenUnit unit -> [GenInstantiatedUnit unit]
goUnitId (GenUnit unit -> [GenInstantiatedUnit unit])
-> GenUnit unit -> [GenInstantiatedUnit unit]
forall a b. (a -> b) -> a -> b
$ GenModule (GenUnit unit) -> GenUnit unit
forall unit. GenModule unit -> unit
moduleUnit (GenModule (GenUnit unit) -> GenUnit unit)
-> GenModule (GenUnit unit) -> GenUnit unit
forall a b. (a -> b) -> a -> b
$ (ModuleName, GenModule (GenUnit unit)) -> GenModule (GenUnit unit)
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 = (ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey ((ModuleGraphNode -> Bool) -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
uid) (UnitId -> Bool)
-> (ModuleGraphNode -> UnitId) -> ModuleGraphNode -> Bool
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 = (NodeKey -> Bool) -> [NodeKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (NodeKey -> NodeKey -> Bool
forall a. Eq a => a -> a -> Bool
== ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
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 GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib
in if | DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkBinary Bool -> Bool -> Bool
&& Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust Maybe FilePath
ofile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
do_linking ->
Either DriverMessages ModuleGraphNode
-> Maybe (Either DriverMessages ModuleGraphNode)
forall a. a -> Maybe a
Just (DriverMessages -> Either DriverMessages ModuleGraphNode
forall a b. a -> Either a b
Left (DriverMessages -> Either DriverMessages ModuleGraphNode)
-> DriverMessages -> Either DriverMessages ModuleGraphNode
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverRedirectedNoMain (ModuleName -> DriverMessage) -> ModuleName -> DriverMessage
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName
mainModuleNameIs DynFlags
dflags))
| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcLink
NoLink, Bool
do_linking -> Either DriverMessages ModuleGraphNode
-> Maybe (Either DriverMessages ModuleGraphNode)
forall a. a -> Maybe a
Just (ModuleGraphNode -> Either DriverMessages ModuleGraphNode
forall a b. b -> Either a b
Right ([NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
unit_nodes UnitId
uid))
| Bool
otherwise -> Maybe (Either DriverMessages ModuleGraphNode)
forall a. Maybe a
Nothing
warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages
warnMissingHomeModules DynFlags
dflags [Target]
targets ModuleGraph
mod_graph =
if [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing
then DriverMessages
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 =
ModSummary -> Bool
is_module_target ModSummary
mod
Bool -> Bool -> Bool
||
Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FilePath -> Bool
is_file_target (ModLocation -> Maybe FilePath
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod))
is_module_target :: ModSummary -> Bool
is_module_target ModSummary
mod = (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod), ModSummary -> UnitId
ms_unitid ModSummary
mod) (ModuleName, UnitId) -> Set (ModuleName, UnitId) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (ModuleName, UnitId)
mod_targets
is_file_target :: FilePath -> Bool
is_file_target FilePath
file = FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (FilePath -> FilePath
withoutExt FilePath
file) Set FilePath
file_targets
file_targets :: Set FilePath
file_targets = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList ((Target -> Maybe FilePath) -> [Target] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Target -> Maybe FilePath
file_target [Target]
targets)
file_target :: Target -> Maybe FilePath
file_target Target {TargetId
targetId :: TargetId
targetId :: Target -> TargetId
targetId} =
case TargetId
targetId of
TargetModule ModuleName
_ -> Maybe FilePath
forall a. Maybe a
Nothing
TargetFile FilePath
file Maybe Phase
_ ->
FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> FilePath
withoutExt (DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
file))
mod_targets :: Set (ModuleName, UnitId)
mod_targets = [(ModuleName, UnitId)] -> Set (ModuleName, UnitId)
forall a. Ord a => [a] -> Set a
Set.fromList (Target -> (ModuleName, UnitId)
mod_target (Target -> (ModuleName, UnitId))
-> [Target] -> [(ModuleName, UnitId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Target]
targets)
mod_target :: Target -> (ModuleName, UnitId)
mod_target Target {UnitId
targetUnitId :: UnitId
targetUnitId :: Target -> UnitId
targetUnitId, TargetId
targetId :: Target -> TargetId
targetId :: TargetId
targetId} =
case TargetId
targetId of
TargetModule ModuleName
name -> (ModuleName
name, UnitId
targetUnitId)
TargetFile FilePath
file Maybe Phase
_ -> (FilePath -> ModuleName
mkModuleName (FilePath -> FilePath
withoutExt FilePath
file), UnitId
targetUnitId)
withoutExt :: FilePath -> FilePath
withoutExt = (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, FilePath) -> FilePath)
-> (FilePath -> (FilePath, FilePath)) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> (FilePath, FilePath)
splitExtension
missing :: [ModuleName]
missing = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) ([ModSummary] -> [ModuleName]) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
(ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModSummary -> Bool) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
is_known_module) ([ModSummary] -> [ModSummary]) -> [ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$
((ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> ModSummary -> UnitId
ms_unitid ModSummary
ms UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
(ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph))
warn :: DriverMessages
warn = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
(DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
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
[ReexportedModule]
reexported_warns <- (ReexportedModule -> IO Bool)
-> [ReexportedModule] -> IO [ReexportedModule]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ReexportedModule -> IO Bool
check_reexport [ReexportedModule]
reexported_mods
return $ Set ModuleName -> [ReexportedModule] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ReexportedModule]
reexported_warns
where
diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
unit_mods :: Set ModuleName
unit_mods = [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name
((ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> ModSummary -> UnitId
ms_unitid ModSummary
ms UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
(ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)))
reexported_mods :: [ReexportedModule]
reexported_mods = DynFlags -> [ReexportedModule]
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 Set ModuleName -> Set ModuleName -> Set ModuleName
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 :: ReexportedModule -> IO Bool
check_reexport ReexportedModule
mn = do
FindResult
fr <- ModuleName -> IO FindResult
lookupModule (ReexportedModule -> ModuleName
reexportFrom ReexportedModule
mn)
case FindResult
fr of
Found ModLocation
_ Module
m -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> UnitId
moduleUnitId Module
m UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
FindResult
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
warn :: DriverMessage -> DriverMessages
warn DriverMessage
diagnostic = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
noSrcSpan
(DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage
diagnostic
final_msgs :: Set ModuleName -> [ReexportedModule] -> DriverMessages
final_msgs Set ModuleName
hidden_warns [ReexportedModule]
reexported_warns
=
[DriverMessages] -> DriverMessages
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages ([DriverMessages] -> DriverMessages)
-> [DriverMessages] -> DriverMessages
forall a b. (a -> b) -> a -> b
$
[DriverMessage -> DriverMessages
warn (UnitId -> [ModuleName] -> DriverMessage
DriverUnknownHiddenModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
hidden_warns)) | Bool -> Bool
not (Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null Set ModuleName
hidden_warns)]
[DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessage -> DriverMessages
warn (UnitId -> [ReexportedModule] -> DriverMessage
DriverUnknownReexportedModules (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) [ReexportedModule]
reexported_warns) | Bool -> Bool
not ([ReexportedModule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ReexportedModule]
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) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"CachedIface", ModNodeKeyWithUid -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> ModNodeKeyWithUid
miKey ModIface
mi), HomeModLinkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr HomeModLinkable
ln]
noIfaceCache :: Maybe ModIfaceCache
noIfaceCache :: Maybe ModIfaceCache
noIfaceCache = Maybe ModIfaceCache
forall a. Maybe a
Nothing
newIfaceCache :: IO ModIfaceCache
newIfaceCache :: IO ModIfaceCache
newIfaceCache = do
IORef [CachedIface]
ioref <- [CachedIface] -> IO (IORef [CachedIface])
forall a. a -> IO (IORef a)
newIORef []
return $
ModIfaceCache
{ iface_clearCache :: IO [CachedIface]
iface_clearCache = IORef [CachedIface]
-> ([CachedIface] -> ([CachedIface], [CachedIface]))
-> IO [CachedIface]
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 -> IORef [CachedIface]
-> ([CachedIface] -> ([CachedIface], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [CachedIface]
ioref (\[CachedIface]
c -> (CachedIface
hmiCachedIface -> [CachedIface] -> [CachedIface]
forall a. a -> [a] -> [a]
:[CachedIface]
c, ()))
}
load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
load :: forall (f :: * -> *). GhcMonad f => LoadHowMuch -> f SuccessFlag
load LoadHowMuch
how_much = Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic) -> LoadHowMuch -> f SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic) -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
noIfaceCache GhcMessage -> AnyGhcDiagnostic
forall a.
(Typeable a, Diagnostic a) =>
a -> UnknownDiagnostic (DiagnosticOpts a)
mkUnknownDiagnostic LoadHowMuch
how_much
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg :: HscEnv -> Messager
mkBatchMsg HscEnv
hsc_env =
if Set UnitId -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HscEnv -> Set UnitId
hsc_all_home_unit_ids HscEnv
hsc_env) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
then Messager
batchMultiMsg
else Messager
batchMsg
type AnyGhcDiagnostic = UnknownDiagnostic (DiagnosticOpts GhcMessage)
loadWithCache :: GhcMonad m => Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic)
-> LoadHowMuch
-> m SuccessFlag
loadWithCache :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic) -> LoadHowMuch -> m SuccessFlag
loadWithCache Maybe ModIfaceCache
cache GhcMessage -> AnyGhcDiagnostic
diag_wrapper LoadHowMuch
how_much = do
Messager
msg <- HscEnv -> Messager
mkBatchMsg (HscEnv -> Messager) -> m HscEnv -> m Messager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
(DriverMessages
errs, ModuleGraph
mod_graph) <- (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
(GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModuleName]
-> Bool
-> m (DriverMessages, ModuleGraph)
depanalE GhcMessage -> AnyGhcDiagnostic
diag_wrapper (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
msg) [] Bool
False
SuccessFlag
success <- Maybe ModIfaceCache
-> LoadHowMuch
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> ModuleGraph
-> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> ModuleGraph
-> m SuccessFlag
load' Maybe ModIfaceCache
cache LoadHowMuch
how_much GhcMessage -> AnyGhcDiagnostic
diag_wrapper (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
msg) ModuleGraph
mod_graph
if DriverMessages -> Bool
forall e. Messages e -> Bool
isEmptyMessages DriverMessages
errs
then SuccessFlag -> m SuccessFlag
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuccessFlag
success
else Messages GhcMessage -> m SuccessFlag
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors ((DriverMessage -> GhcMessage)
-> DriverMessages -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
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
home_mod_sum :: [ModSummary]
home_mod_sum = (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModSummary
ms -> DynFlags -> UnitId
homeUnitId_ DynFlags
dflags UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> UnitId
ms_unitid ModSummary
ms) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)
loadedPackages :: [UnitInfo]
loadedPackages = [[UnitInfo]] -> [UnitInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[UnitInfo]] -> [UnitInfo]) -> [[UnitInfo]] -> [UnitInfo]
forall a b. (a -> b) -> a -> b
$
((PkgQual, GenLocated SrcSpan ModuleName) -> Maybe [UnitInfo])
-> [(PkgQual, GenLocated SrcSpan ModuleName)] -> [[UnitInfo]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(PkgQual
fs, GenLocated SrcSpan ModuleName
mn) -> UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage UnitState
us (GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
mn) PkgQual
fs)
([(PkgQual, GenLocated SrcSpan ModuleName)] -> [[UnitInfo]])
-> [(PkgQual, GenLocated SrcSpan ModuleName)] -> [[UnitInfo]]
forall a b. (a -> b) -> a -> b
$ (ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)])
-> [ModSummary] -> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [(PkgQual, GenLocated SrcSpan ModuleName)]
ms_imps [ModSummary]
home_mod_sum
any_import_ghc_prim :: Bool
any_import_ghc_prim = (ModSummary -> Bool) -> [ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ModSummary -> Bool
ms_ghc_prim_import [ModSummary]
home_mod_sum
used_args :: Set UnitId
used_args = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
loadedPackages)
Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList [ UnitId
primUnitId | Bool
any_import_ghc_prim ]
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
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui) Set UnitId
used_args)
return (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui, UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
ui, UnitInfo -> Version
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
unitPackageVersion UnitInfo
ui, PackageArg
flag)
unusedArgs :: [(UnitId, PackageName, Version, PackageArg)]
unusedArgs = ((UnitId, PackageName, Version, PackageArg) -> UnitId)
-> [(UnitId, PackageName, Version, PackageArg)]
-> [(UnitId, PackageName, Version, PackageArg)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(UnitId
u,PackageName
_,Version
_,PackageArg
_) -> UnitId
u) ([(UnitId, PackageName, Version, PackageArg)]
-> [(UnitId, PackageName, Version, PackageArg)])
-> [(UnitId, PackageName, Version, PackageArg)]
-> [(UnitId, PackageName, Version, PackageArg)]
forall a b. (a -> b) -> a -> b
$ ((GenUnit UnitId, Maybe PackageArg)
-> Maybe (UnitId, PackageName, Version, PackageArg))
-> [(GenUnit UnitId, Maybe PackageArg)]
-> [(UnitId, PackageName, Version, PackageArg)]
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 = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
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 [(UnitId, PackageName, Version, PackageArg)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitId, PackageName, Version, PackageArg)]
unusedArgs
then DriverMessages
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) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"ModeGraphNodeWithBootFile: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleGraphNode -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [NodeKey] -> SDoc
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) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"SingleModule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (ModuleGraphNode -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleGraphNode
mgn)
ppr (ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"ResolvedCycle:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mgn
ppr (UnresolvedCycle [ModuleGraphNode]
mgn) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"UnresolvedCycle:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ModuleGraphNode] -> SDoc
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) = [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ns
countMods (UnresolvedCycle [ModuleGraphNode]
ns) = [ModuleGraphNode] -> Int
forall a. [a] -> Int
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
| ModuleEnv (ModuleGraphNode, [ModuleGraphNode]) -> Bool
forall a. ModuleEnv a -> Bool
isEmptyModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = [SCC ModuleGraphNode] -> [BuildPlan]
collapseAcyclic ([SCC ModuleGraphNode] -> [BuildPlan])
-> [SCC ModuleGraphNode] -> [BuildPlan]
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
nodeModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall 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 :: Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle = [SCC ModuleGraphNode]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC ([ModuleGraphNode] -> [SCC ModuleGraphNode]
topSortWithBoot [ModuleGraphNode]
nodes)
in [BuildPlan]
acyclic [BuildPlan] -> [BuildPlan] -> [BuildPlan]
forall a. [a] -> [a] -> [a]
++ [([ModuleGraphNode] -> BuildPlan)
-> ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildPlan)
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> BuildPlan
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [ModuleGraphNode] -> BuildPlan
UnresolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildPlan
ResolvedCycle Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
mresolved_cycle] [BuildPlan] -> [BuildPlan] -> [BuildPlan]
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 = Graph SummaryNode
-> (SummaryNode -> NodeKey) -> Map NodeKey (Set NodeKey)
forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachable Graph SummaryNode
mg (ModuleGraphNode -> NodeKey
mkNodeKey (ModuleGraphNode -> NodeKey)
-> (SummaryNode -> ModuleGraphNode) -> SummaryNode -> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SummaryNode -> ModuleGraphNode
forall key payload. Node key payload -> payload
node_payload)
boot_path :: ModuleName -> UnitId -> [ModuleGraphNode]
boot_path ModuleName
mn UnitId
uid =
(NodeKey -> ModuleGraphNode) -> [NodeKey] -> [ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map (SummaryNode -> ModuleGraphNode
summaryNodeSummary (SummaryNode -> ModuleGraphNode)
-> (NodeKey -> SummaryNode) -> NodeKey -> ModuleGraphNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe SummaryNode -> SummaryNode
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"toNode" (Maybe SummaryNode -> SummaryNode)
-> (NodeKey -> Maybe SummaryNode) -> NodeKey -> SummaryNode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node) ([NodeKey] -> [ModuleGraphNode]) -> [NodeKey] -> [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList (Set NodeKey -> [NodeKey]) -> Set NodeKey -> [NodeKey]
forall a b. (a -> b) -> a -> b
$
NodeKey -> Set NodeKey -> Set NodeKey
forall a. Ord a => a -> Set a -> Set a
Set.delete (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot)) (Set NodeKey -> Set NodeKey) -> Set NodeKey -> Set NodeKey
forall a b. (a -> b) -> a -> b
$
(NodeKey -> Bool) -> Set NodeKey -> Set NodeKey
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\NodeKey
nk -> NodeKey -> UnitId
nodeKeyUnitId NodeKey
nk UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
uid
Bool -> Bool -> Bool
&& (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (IsBootInterface -> ModNodeKeyWithUid
key IsBootInterface
IsBoot)) NodeKey -> Set NodeKey -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` FilePath -> Maybe (Set NodeKey) -> Set NodeKey
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"dep_on_boot" (NodeKey -> Map NodeKey (Set NodeKey) -> Maybe (Set NodeKey)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
nk Map NodeKey (Set NodeKey)
trans_deps_map)) (Set NodeKey -> Set NodeKey) -> Set NodeKey -> Set NodeKey
forall a b. (a -> b) -> a -> b
$
FilePath -> Maybe (Set NodeKey) -> Set NodeKey
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"not_boot_dep" (NodeKey -> Map NodeKey (Set NodeKey) -> Maybe (Set NodeKey)
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 (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
ib) UnitId
uid
boot_modules :: ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules = [(Module, (ModuleGraphNode, [ModuleGraphNode]))]
-> ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
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 IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules = (ModuleGraphNode -> Maybe ModuleGraphNode)
-> [ModuleGraphNode] -> [ModuleGraphNode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((ModuleGraphNode, [ModuleGraphNode]) -> ModuleGraphNode)
-> Maybe (ModuleGraphNode, [ModuleGraphNode])
-> Maybe ModuleGraphNode
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleGraphNode, [ModuleGraphNode]) -> ModuleGraphNode
forall a b. (a, b) -> a
fst (Maybe (ModuleGraphNode, [ModuleGraphNode])
-> Maybe ModuleGraphNode)
-> (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))
-> ModuleGraphNode
-> Maybe ModuleGraphNode
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 -> ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
-> Module -> Maybe (ModuleGraphNode, [ModuleGraphNode])
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv (ModuleGraphNode, [ModuleGraphNode])
boot_modules (ModSummary -> Module
ms_mod ModSummary
ms); ModuleGraphNode
_ -> Maybe (ModuleGraphNode, [ModuleGraphNode])
forall a. Maybe a
Nothing
collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
collapseSCC :: [SCC ModuleGraphNode]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [AcyclicSCC ModuleGraphNode
node1, AcyclicSCC ModuleGraphNode
node2] = [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a b. b -> Either a b
Right [ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node1, ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node2]
collapseSCC (AcyclicSCC ModuleGraphNode
node : [SCC ModuleGraphNode]
nodes) = ([ModuleGraphNode]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([ModuleGraphNode]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a b. a -> Either a b
Left ([ModuleGraphNode]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> ([ModuleGraphNode] -> [ModuleGraphNode])
-> [ModuleGraphNode]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleGraphNode
node ModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. a -> [a] -> [a]
:)) ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a b. b -> Either a b
Right ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> ([Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile])
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
toNodeWithBoot ModuleGraphNode
node Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a. a -> [a] -> [a]
:)) ([SCC ModuleGraphNode]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
collapseSCC [SCC ModuleGraphNode]
nodes)
collapseSCC [SCC ModuleGraphNode]
nodes = [ModuleGraphNode]
-> Either
[ModuleGraphNode]
[Either ModuleGraphNode ModuleGraphNodeWithBootFile]
forall a b. a -> Either a b
Left ([SCC ModuleGraphNode] -> [ModuleGraphNode]
forall a. [SCC a] -> [a]
flattenSCCs [SCC ModuleGraphNode]
nodes)
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 -> ModuleGraphNode
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
forall a b. a -> Either a b
Left ModuleGraphNode
mn
Just (ModuleGraphNode, [ModuleGraphNode])
path -> ModuleGraphNodeWithBootFile
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
forall a b. b -> Either a b
Right (ModuleGraphNode -> [NodeKey] -> ModuleGraphNodeWithBootFile
ModuleGraphNodeWithBootFile ModuleGraphNode
mn ((ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey ((ModuleGraphNode, [ModuleGraphNode]) -> [ModuleGraphNode]
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 BuildPlan -> [BuildPlan] -> [BuildPlan]
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) BuildPlan -> [BuildPlan] -> [BuildPlan]
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 [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
nodes) Maybe HomeUnitModule
forall a. Maybe a
Nothing
in
Bool -> SDoc -> [BuildPlan] -> [BuildPlan]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ModuleGraphNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph))
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Build plan missing nodes:", (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"PLAN:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
build_plan))), (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"GRAPH:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([ModuleGraphNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mod_graph )))])
[BuildPlan]
build_plan
mkWorkerLimit :: DynFlags -> IO WorkerLimit
mkWorkerLimit :: DynFlags -> IO WorkerLimit
mkWorkerLimit DynFlags
dflags =
case DynFlags -> Maybe ParMakeCount
parMakeCount DynFlags
dflags of
Maybe ParMakeCount
Nothing -> WorkerLimit -> IO WorkerLimit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WorkerLimit -> IO WorkerLimit) -> WorkerLimit -> IO WorkerLimit
forall a b. (a -> b) -> a -> b
$ Int -> WorkerLimit
num_procs Int
1
Just (ParMakeSemaphore FilePath
h) -> WorkerLimit -> IO WorkerLimit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SemaphoreName -> WorkerLimit
JSemLimit (FilePath -> SemaphoreName
SemaphoreName FilePath
h))
Just ParMakeCount
ParMakeNumProcessors -> Int -> WorkerLimit
num_procs (Int -> WorkerLimit) -> IO Int -> IO WorkerLimit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getNumProcessors
Just (ParMakeThisMany Int
n) -> WorkerLimit -> IO WorkerLimit
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WorkerLimit -> IO WorkerLimit) -> WorkerLimit -> IO WorkerLimit
forall a b. (a -> b) -> a -> b
$ Int -> WorkerLimit
num_procs Int
n
where
num_procs :: Int -> WorkerLimit
num_procs Int
x = Int -> WorkerLimit
NumProcessorsLimit (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
x)
isWorkerLimitSequential :: WorkerLimit -> Bool
isWorkerLimitSequential :: WorkerLimit -> Bool
isWorkerLimitSequential (NumProcessorsLimit Int
x) = Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
isWorkerLimitSequential (JSemLimit {}) = Bool
False
data WorkerLimit
= NumProcessorsLimit Int
| JSemLimit
SemaphoreName
deriving WorkerLimit -> WorkerLimit -> Bool
(WorkerLimit -> WorkerLimit -> Bool)
-> (WorkerLimit -> WorkerLimit -> Bool) -> Eq WorkerLimit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WorkerLimit -> WorkerLimit -> Bool
== :: WorkerLimit -> WorkerLimit -> Bool
$c/= :: WorkerLimit -> WorkerLimit -> Bool
/= :: WorkerLimit -> WorkerLimit -> Bool
Eq
load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: forall (m :: * -> *).
GhcMonad m =>
Maybe ModIfaceCache
-> LoadHowMuch
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> ModuleGraph
-> m SuccessFlag
load' Maybe ModIfaceCache
mhmi_cache LoadHowMuch
how_much GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessage ModuleGraph
mod_graph = do
m ()
forall (m :: * -> *). GhcMonad m => m ()
initializeSessionPlugins
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph = mod_graph }
m ()
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
HscEnv
hsc_env <- m HscEnv
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 =
[HomeUnitModule] -> Set HomeUnitModule
forall a. Ord a => [a] -> Set a
Set.fromList [ UnitId -> ModuleName -> HomeUnitModule
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 IsBootInterface -> IsBootInterface -> Bool
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
_ = m SuccessFlag -> m SuccessFlag
forall a. a -> a
id
checkMod :: HomeUnitModule -> m SuccessFlag -> m SuccessFlag
checkMod HomeUnitModule
m m SuccessFlag
and_then
| HomeUnitModule
m HomeUnitModule -> Set HomeUnitModule -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HomeUnitModule
all_home_mods = m SuccessFlag
and_then
| Bool
otherwise = do
MsgEnvelope GhcMessage -> m SuccessFlag
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> m SuccessFlag)
-> MsgEnvelope GhcMessage -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan
(GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage
(DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ ModuleName -> DriverMessage
DriverModuleNotFound (HomeUnitModule -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName HomeUnitModule
m)
LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch LoadHowMuch
how_much (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
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 Maybe HomeUnitModule
forall a. Maybe a
Nothing
[SCC ModSummary] -> m ()
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 -> HomeUnitModule -> Maybe HomeUnitModule
forall a. a -> Maybe a
Just HomeUnitModule
m
LoadDependenciesOf HomeUnitModule
m -> HomeUnitModule -> Maybe HomeUnitModule
forall a. a -> Maybe a
Just HomeUnitModule
m
LoadHowMuch
_ -> Maybe HomeUnitModule
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 <- IO [CachedIface] -> m [CachedIface]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [CachedIface] -> m [CachedIface])
-> IO [CachedIface] -> m [CachedIface]
forall a b. (a -> b) -> a -> b
$ IO [CachedIface]
-> (ModIfaceCache -> IO [CachedIface])
-> Maybe ModIfaceCache
-> IO [CachedIface]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([CachedIface] -> IO [CachedIface]
forall a. a -> IO a
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
([SCC ModSummary] -> [ModSummary]
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 = emptyHomePackageTable }
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ (UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG ((HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv) HscEnv
hsc_env
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Interp -> HscEnv -> IO ()
unload Interp
interp HscEnv
hsc_env
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Ready for upsweep")
Int
2 ([BuildPlan] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BuildPlan]
build_plan))
WorkerLimit
worker_limit <- IO WorkerLimit -> m WorkerLimit
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WorkerLimit -> m WorkerLimit)
-> IO WorkerLimit -> m WorkerLimit
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO WorkerLimit
mkWorkerLimit DynFlags
dflags
(SuccessFlag
upsweep_ok, [HomeModInfo]
new_deps) <- m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics (m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo]))
-> m (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SuccessFlag, [HomeModInfo]) -> m (SuccessFlag, [HomeModInfo]))
-> IO (SuccessFlag, [HomeModInfo])
-> m (SuccessFlag, [HomeModInfo])
forall a b. (a -> b) -> a -> b
$ WorkerLimit
-> HscEnv
-> Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, [HomeModInfo])
upsweep WorkerLimit
worker_limit HscEnv
hsc_env Maybe ModIfaceCache
mhmi_cache GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessage ([HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
pruned_cache) [BuildPlan]
build_plan
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ([HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv [HomeModInfo]
new_deps)
case SuccessFlag
upsweep_ok of
SuccessFlag
Failed -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *). GhcMonad m => SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
upsweep_ok
SuccessFlag
Succeeded -> do
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Upsweep completely successful.")
SuccessFlag -> m SuccessFlag
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 (HscEnv -> HscEnv) -> m ()
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 = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
env ->
let !mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
new_home_graph :: UnitEnvGraph HomeUnitEnv
new_home_graph =
((HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> (HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall v. (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_map (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
env) ((HomeUnitEnv -> HomeUnitEnv) -> UnitEnvGraph HomeUnitEnv)
-> (HomeUnitEnv -> HomeUnitEnv) -> UnitEnvGraph HomeUnitEnv
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 = (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
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 -> (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
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
_ -> (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
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' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
mainModuleSrcPath'
then GhcException -> Maybe FilePath
forall a. GhcException -> a
throwGhcException (GhcException -> Maybe FilePath)
-> (FilePath -> GhcException) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcException
UsageError (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$
FilePath
"default output name would overwrite the input file; " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
FilePath
"must specify -o explicitly"
else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
name'
in
case DynFlags -> Maybe FilePath
outputFile_ DynFlags
dflags of
Just FilePath
_ -> HomeUnitEnv
hue
Maybe FilePath
Nothing -> HomeUnitEnv
hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }
in HscEnv
env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }
pruneCache :: [CachedIface]
-> [ModSummary]
-> [HomeModInfo]
pruneCache :: [CachedIface] -> [ModSummary] -> [HomeModInfo]
pruneCache [CachedIface]
hpt [ModSummary]
summ
= (CachedIface -> HomeModInfo) -> [CachedIface] -> [HomeModInfo]
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 <- ModNodeKeyWithUid
-> Map ModNodeKeyWithUid ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModNodeKeyWithUid
modl Map ModNodeKeyWithUid ModSummary
ms_map
, ModIface -> Fingerprint
forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_src_hash ModIface
iface Fingerprint -> Fingerprint -> Bool
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 = (ModSummary -> ModSummary -> ModSummary)
-> [(ModNodeKeyWithUid, ModSummary)]
-> Map ModNodeKeyWithUid ModSummary
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
(\ModSummary
ms1 ModSummary
ms2 -> Bool -> SDoc -> ModSummary -> ModSummary
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"prune_cache" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (ModSummary -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModSummary
ms1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModSummary -> SDoc
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 -> () -> IO ()
forall a. a -> IO a
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 = (a -> a) -> MVar (Maybe a) -> ResultVar a
forall b a. (a -> b) -> MVar (Maybe a) -> ResultVar b
ResultVar a -> a
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) = IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT ((a -> a) -> Maybe a -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f (Maybe a -> Maybe a) -> IO (Maybe a) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Maybe a) -> IO (Maybe a)
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
(Int -> ResultOrigin -> FilePath -> FilePath)
-> (ResultOrigin -> FilePath)
-> ([ResultOrigin] -> FilePath -> FilePath)
-> Show ResultOrigin
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ResultOrigin -> FilePath -> FilePath
showsPrec :: Int -> ResultOrigin -> FilePath -> FilePath
$cshow :: ResultOrigin -> FilePath
show :: ResultOrigin -> FilePath
$cshowList :: [ResultOrigin] -> FilePath -> FilePath
showList :: [ResultOrigin] -> FilePath -> FilePath
Show)
data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Int -> ResultLoopOrigin -> FilePath -> FilePath
[ResultLoopOrigin] -> FilePath -> FilePath
ResultLoopOrigin -> FilePath
(Int -> ResultLoopOrigin -> FilePath -> FilePath)
-> (ResultLoopOrigin -> FilePath)
-> ([ResultLoopOrigin] -> FilePath -> FilePath)
-> Show ResultLoopOrigin
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ResultLoopOrigin -> FilePath -> FilePath
showsPrec :: Int -> ResultLoopOrigin -> FilePath -> FilePath
$cshow :: ResultLoopOrigin -> FilePath
show :: ResultLoopOrigin -> FilePath
$cshowList :: [ResultLoopOrigin] -> FilePath -> FilePath
showList :: [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 (UnitEnvGraph HomeUnitEnv)
hug_var :: MVar HomeUnitGraph
}
nodeId :: BuildM Int
nodeId :: BuildM Int
nodeId = do
Int
n <- (BuildLoopState -> Int) -> BuildM Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> Int
nNODE
(BuildLoopState -> BuildLoopState) -> StateT BuildLoopState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { nNODE = n + 1 })
return Int
n
setModulePipeline :: NodeKey -> BuildResult -> BuildM ()
setModulePipeline :: NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline NodeKey
mgn BuildResult
build_result = do
(BuildLoopState -> BuildLoopState) -> StateT BuildLoopState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\BuildLoopState
m -> BuildLoopState
m { buildDep = M.insert mgn build_result (buildDep m) })
type BuildMap = M.Map NodeKey BuildResult
getBuildMap :: BuildM BuildMap
getBuildMap :: BuildM (Map NodeKey BuildResult)
getBuildMap = (BuildLoopState -> Map NodeKey BuildResult)
-> BuildM (Map NodeKey BuildResult)
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 =
(NodeKey -> BuildResult) -> [NodeKey] -> [BuildResult]
forall a b. (a -> b) -> [a] -> [b]
strictMap (FilePath -> Maybe BuildResult -> BuildResult
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"dep_map" (Maybe BuildResult -> BuildResult)
-> (NodeKey -> Maybe BuildResult) -> NodeKey -> BuildResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeKey -> Map NodeKey BuildResult -> Maybe BuildResult)
-> Map NodeKey BuildResult -> NodeKey -> Maybe BuildResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip NodeKey -> Map NodeKey BuildResult -> Maybe BuildResult
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 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)
, MakeEnv -> GhcMessage -> AnyGhcDiagnostic
diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
}
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 :: UnitEnvGraph HomeUnitEnv
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan UnitEnvGraph HomeUnitEnv
hug Maybe ModIfaceCache
mhmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
plan = do
MVar (UnitEnvGraph HomeUnitEnv)
hug_var <- UnitEnvGraph HomeUnitEnv -> IO (MVar (UnitEnvGraph HomeUnitEnv))
forall a. a -> IO (MVar a)
newMVar UnitEnvGraph HomeUnitEnv
hug
((Maybe [ModuleGraphNode]
mcycle, [MakeAction]
plans), BuildLoopState
build_map) <- StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
-> BuildLoopState
-> IO ((Maybe [ModuleGraphNode], [MakeAction]), BuildLoopState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ([BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plan) (Map NodeKey BuildResult
-> Int -> MVar (UnitEnvGraph HomeUnitEnv) -> BuildLoopState
BuildLoopState Map NodeKey BuildResult
forall k a. Map k a
M.empty Int
1 MVar (UnitEnvGraph HomeUnitEnv)
hug_var)
let wait :: IO [Maybe (Maybe HomeModInfo)]
wait = Map NodeKey BuildResult -> IO [Maybe (Maybe HomeModInfo)]
forall {k}. Map k BuildResult -> IO [Maybe (Maybe HomeModInfo)]
collect_results (BuildLoopState -> Map NodeKey BuildResult
buildDep BuildLoopState
build_map)
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
-> IO
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f 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 =
[IO (Maybe (Maybe HomeModInfo))] -> IO [Maybe (Maybe HomeModInfo)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((BuildResult -> IO (Maybe (Maybe HomeModInfo)))
-> [BuildResult] -> [IO (Maybe (Maybe HomeModInfo))]
forall a b. (a -> b) -> [a] -> [b]
map (\BuildResult
br -> ResultVar (Maybe HomeModInfo) -> IO (Maybe (Maybe HomeModInfo))
forall {a}. ResultVar a -> IO (Maybe a)
collect_result ((Maybe HomeModInfo, ModuleNameSet) -> Maybe HomeModInfo
forall a b. (a, b) -> a
fst ((Maybe HomeModInfo, ModuleNameSet) -> Maybe HomeModInfo)
-> ResultVar (Maybe HomeModInfo, ModuleNameSet)
-> ResultVar (Maybe HomeModInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuildResult -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
resultVar BuildResult
br)) (Map k BuildResult -> [BuildResult]
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 = MaybeT IO a -> IO (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (ResultVar a -> MaybeT IO a
forall a. ResultVar a -> MaybeT IO a
waitResult ResultVar a
res_var)
n_mods :: Int
n_mods = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BuildPlan -> Int) -> [BuildPlan] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BuildPlan -> Int
countMods [BuildPlan]
plan)
buildLoop :: [BuildPlan]
-> BuildM (Maybe [ModuleGraphNode], [MakeAction])
buildLoop :: [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [] = (Maybe [ModuleGraphNode], [MakeAction])
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [ModuleGraphNode]
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
-> StateT BuildLoopState IO MakeAction
buildSingleModule Maybe [NodeKey]
forall a. Maybe a
Nothing ResultOrigin
NoLoop ModuleGraphNode
m
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
all_plans) <- [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
return (Maybe [ModuleGraphNode]
cycle, MakeAction
one_plan MakeAction -> [MakeAction] -> [MakeAction]
forall a. a -> [a] -> [a]
: [MakeAction]
all_plans)
ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms -> do
[MakeAction]
pipes <- [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> StateT BuildLoopState IO [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
graph) <- [BuildPlan]
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
buildLoop [BuildPlan]
plans
return (Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipes [MakeAction] -> [MakeAction] -> [MakeAction]
forall a. [a] -> [a] -> [a]
++ [MakeAction]
graph)
UnresolvedCycle [ModuleGraphNode]
ns -> (Maybe [ModuleGraphNode], [MakeAction])
-> StateT BuildLoopState IO (Maybe [ModuleGraphNode], [MakeAction])
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ModuleGraphNode] -> Maybe [ModuleGraphNode]
forall a. a -> Maybe a
Just [ModuleGraphNode]
ns, [])
buildSingleModule :: Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> BuildM MakeAction
buildSingleModule :: Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> StateT BuildLoopState IO 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 (UnitEnvGraph HomeUnitEnv)
hug_var <- (BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv))
-> StateT BuildLoopState IO (MVar (UnitEnvGraph HomeUnitEnv))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv)
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 =
case ModuleGraphNode
mod of
InstantiationNode UnitId
uid InstantiatedUnit
iu -> do
UnitId
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
mod) (RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet))
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a b. (a -> b) -> a -> b
$ do
(UnitEnvGraph HomeUnitEnv
hug, ModuleNameSet
deps) <- MVar (UnitEnvGraph HomeUnitEnv)
-> [BuildResult]
-> ReaderT
MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv, ModuleNameSet)
wait_deps_hug MVar (UnitEnvGraph HomeUnitEnv)
hug_var [BuildResult]
build_deps
Int
-> Int
-> UnitEnvGraph HomeUnitEnv
-> UnitId
-> InstantiatedUnit
-> ReaderT MakeEnv (MaybeT IO) ()
executeInstantiationNode Int
mod_idx Int
n_mods UnitEnvGraph HomeUnitEnv
hug UnitId
uid InstantiatedUnit
iu
return (Maybe HomeModInfo
forall a. Maybe a
Nothing, ModuleNameSet
deps)
ModuleNode [NodeKey]
_build_deps ModSummary
ms ->
let !old_hmi :: Maybe HomeModInfo
old_hmi = ModNodeKeyWithUid
-> Map ModNodeKeyWithUid HomeModInfo -> Maybe HomeModInfo
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 = (NodeKey -> Maybe ModuleName) -> [NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe ModuleName
nodeKeyModName ([NodeKey] -> [ModuleName])
-> Maybe [NodeKey] -> Maybe [ModuleName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [NodeKey]
rehydrate_nodes
in UnitId
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
mod) (RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet))
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a b. (a -> b) -> a -> b
$ do
(UnitEnvGraph HomeUnitEnv
hug, ModuleNameSet
deps) <- MVar (UnitEnvGraph HomeUnitEnv)
-> [BuildResult]
-> ReaderT
MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv, ModuleNameSet)
wait_deps_hug MVar (UnitEnvGraph HomeUnitEnv)
hug_var [BuildResult]
build_deps
HomeModInfo
hmi <- Int
-> Int
-> Maybe HomeModInfo
-> UnitEnvGraph HomeUnitEnv
-> Maybe [ModuleName]
-> ModSummary
-> ReaderT MakeEnv (MaybeT IO) HomeModInfo
executeCompileNode Int
mod_idx Int
n_mods Maybe HomeModInfo
old_hmi UnitEnvGraph HomeUnitEnv
hug Maybe [ModuleName]
rehydrate_mods ModSummary
ms
IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ())
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ()))
-> IO (Maybe ()) -> ReaderT MakeEnv (MaybeT IO) (Maybe ())
forall a b. (a -> b) -> a -> b
$ Maybe ModIfaceCache -> (ModIfaceCache -> IO ()) -> IO (Maybe ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe ModIfaceCache
mhmi_cache ((ModIfaceCache -> IO ()) -> IO (Maybe ()))
-> (ModIfaceCache -> IO ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \ModIfaceCache
hmi_cache -> ModIfaceCache -> HomeModInfo -> IO ()
addHmiToCache ModIfaceCache
hmi_cache HomeModInfo
hmi
IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT MakeEnv (MaybeT IO) ())
-> IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a b. (a -> b) -> a -> b
$ MVar (UnitEnvGraph HomeUnitEnv)
-> (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (UnitEnvGraph HomeUnitEnv)
hug_var (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv))
-> (UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> IO (UnitEnvGraph HomeUnitEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
addHomeModInfoToHug HomeModInfo
hmi)
return (HomeModInfo -> Maybe HomeModInfo
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
UnitId
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
mod) (RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet))
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a b. (a -> b) -> a -> b
$ do
(UnitEnvGraph HomeUnitEnv
hug, ModuleNameSet
deps) <- MVar (UnitEnvGraph HomeUnitEnv)
-> [BuildResult]
-> ReaderT
MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv, ModuleNameSet)
wait_deps_hug MVar (UnitEnvGraph HomeUnitEnv)
hug_var [BuildResult]
build_deps
UnitEnvGraph HomeUnitEnv
-> (Int, Int)
-> UnitId
-> [NodeKey]
-> ReaderT MakeEnv (MaybeT IO) ()
executeLinkNode UnitEnvGraph HomeUnitEnv
hug (Int
mod_idx, Int
n_mods) UnitId
uid [NodeKey]
direct_deps
return (Maybe HomeModInfo
forall a. Maybe a
Nothing, ModuleNameSet
deps)
MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
res_var <- IO (MVar (Maybe (Maybe HomeModInfo, ModuleNameSet)))
-> StateT
BuildLoopState IO (MVar (Maybe (Maybe HomeModInfo, ModuleNameSet)))
forall a. IO a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar (Maybe (Maybe HomeModInfo, ModuleNameSet)))
forall a. IO (MVar a)
newEmptyMVar
let result_var :: ResultVar (Maybe HomeModInfo, ModuleNameSet)
result_var = MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
-> ResultVar (Maybe HomeModInfo, ModuleNameSet)
forall a. MVar (Maybe a) -> ResultVar a
mkResultVar MVar (Maybe (Maybe HomeModInfo, ModuleNameSet))
res_var
NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mod) (ResultOrigin
-> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
mkBuildResult ResultOrigin
origin ResultVar (Maybe HomeModInfo, ModuleNameSet)
result_var)
MakeAction -> StateT BuildLoopState IO MakeAction
forall a. a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MakeAction -> StateT BuildLoopState IO MakeAction)
-> MakeAction -> StateT BuildLoopState IO MakeAction
forall a b. (a -> b) -> a -> b
$! (RunMakeM (Maybe HomeModInfo, ModuleNameSet)
-> MVar (Maybe (Maybe HomeModInfo, ModuleNameSet)) -> MakeAction
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
-> StateT BuildLoopState IO [MakeAction]
buildOneLoopyModule (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [NodeKey]
deps) = do
MakeAction
ma <- Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> StateT BuildLoopState IO MakeAction
buildSingleModule ([NodeKey] -> Maybe [NodeKey]
forall a. a -> Maybe a
Just [NodeKey]
deps) (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
Initialise) ModuleGraphNode
mn
MakeAction
rehydrate_action <- ResultLoopOrigin
-> [GenWithIsBoot NodeKey] -> StateT BuildLoopState IO MakeAction
rehydrateAction ResultLoopOrigin
Rehydrated ((NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
IsBoot) GenWithIsBoot NodeKey
-> [GenWithIsBoot NodeKey] -> [GenWithIsBoot NodeKey]
forall a. a -> [a] -> [a]
: ((NodeKey -> GenWithIsBoot NodeKey)
-> [NodeKey] -> [GenWithIsBoot NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map (\NodeKey
d -> NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
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]
-> StateT BuildLoopState IO [MakeAction]
buildModuleLoop [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms = do
[MakeAction]
build_modules <- (Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> StateT BuildLoopState IO [MakeAction])
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> StateT BuildLoopState IO [MakeAction]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM ((ModuleGraphNode -> StateT BuildLoopState IO [MakeAction])
-> (ModuleGraphNodeWithBootFile
-> StateT BuildLoopState IO [MakeAction])
-> Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> StateT BuildLoopState IO [MakeAction]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((MakeAction -> [MakeAction])
-> StateT BuildLoopState IO MakeAction
-> StateT BuildLoopState IO [MakeAction]
forall a b.
(a -> b)
-> StateT BuildLoopState IO a -> StateT BuildLoopState IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MakeAction -> [MakeAction] -> [MakeAction]
forall a. a -> [a] -> [a]
:[]) (StateT BuildLoopState IO MakeAction
-> StateT BuildLoopState IO [MakeAction])
-> (ModuleGraphNode -> StateT BuildLoopState IO MakeAction)
-> ModuleGraphNode
-> StateT BuildLoopState IO [MakeAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [NodeKey]
-> ResultOrigin
-> ModuleGraphNode
-> StateT BuildLoopState IO MakeAction
buildSingleModule Maybe [NodeKey]
forall a. Maybe a
Nothing (ResultLoopOrigin -> ResultOrigin
Loop ResultLoopOrigin
Initialise)) ModuleGraphNodeWithBootFile
-> StateT BuildLoopState IO [MakeAction]
buildOneLoopyModule) [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
let extract :: Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey
extract (Left ModuleGraphNode
mn) = NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
NotBoot
extract (Right (ModuleGraphNodeWithBootFile ModuleGraphNode
mn [NodeKey]
_)) = NodeKey -> IsBootInterface -> GenWithIsBoot NodeKey
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
mn) IsBootInterface
IsBoot
let loop_mods :: [GenWithIsBoot NodeKey]
loop_mods = (Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey)
-> [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-> [GenWithIsBoot NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map Either ModuleGraphNode ModuleGraphNodeWithBootFile
-> GenWithIsBoot NodeKey
extract [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
ms
MakeAction
rehydrate_action <- ResultLoopOrigin
-> [GenWithIsBoot NodeKey] -> StateT BuildLoopState IO MakeAction
rehydrateAction ResultLoopOrigin
Finalised [GenWithIsBoot NodeKey]
loop_mods
return $ [MakeAction]
build_modules [MakeAction] -> [MakeAction] -> [MakeAction]
forall a. [a] -> [a] -> [a]
++ [MakeAction
rehydrate_action]
rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
rehydrateAction :: ResultLoopOrigin
-> [GenWithIsBoot NodeKey] -> StateT BuildLoopState IO MakeAction
rehydrateAction ResultLoopOrigin
origin [GenWithIsBoot NodeKey]
deps = do
MVar (UnitEnvGraph HomeUnitEnv)
hug_var <- (BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv))
-> StateT BuildLoopState IO (MVar (UnitEnvGraph HomeUnitEnv))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets BuildLoopState -> MVar (UnitEnvGraph HomeUnitEnv)
hug_var
!Map NodeKey BuildResult
build_map <- BuildM (Map NodeKey BuildResult)
getBuildMap
MVar (Maybe ([HomeModInfo], ModuleNameSet))
res_var <- IO (MVar (Maybe ([HomeModInfo], ModuleNameSet)))
-> StateT
BuildLoopState IO (MVar (Maybe ([HomeModInfo], ModuleNameSet)))
forall a. IO a -> StateT BuildLoopState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar (Maybe ([HomeModInfo], ModuleNameSet)))
forall a. IO (MVar a)
newEmptyMVar
let loop_unit :: UnitId
!loop_unit :: UnitId
loop_unit = NodeKey -> UnitId
nodeKeyUnitId (GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod ([GenWithIsBoot NodeKey] -> GenWithIsBoot NodeKey
forall a. HasCallStack => [a] -> a
head [GenWithIsBoot NodeKey]
deps))
!build_deps :: [BuildResult]
build_deps = [NodeKey] -> Map NodeKey BuildResult -> [BuildResult]
getDependencies ((GenWithIsBoot NodeKey -> NodeKey)
-> [GenWithIsBoot NodeKey] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod [GenWithIsBoot NodeKey]
deps) Map NodeKey BuildResult
build_map
let loop_action :: RunMakeM ([HomeModInfo], ModuleNameSet)
loop_action = UnitId
-> RunMakeM ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
loop_unit (RunMakeM ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet))
-> RunMakeM ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a b. (a -> b) -> a -> b
$ do
(UnitEnvGraph HomeUnitEnv
hug, ModuleNameSet
tdeps) <- MVar (UnitEnvGraph HomeUnitEnv)
-> [BuildResult]
-> ReaderT
MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv, ModuleNameSet)
wait_deps_hug MVar (UnitEnvGraph HomeUnitEnv)
hug_var [BuildResult]
build_deps
HscEnv
hsc_env <- (MakeEnv -> HscEnv) -> ReaderT MakeEnv (MaybeT IO) HscEnv
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> HscEnv
hsc_env
let new_hsc :: HscEnv
new_hsc = UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
hug HscEnv
hsc_env
mns :: [ModuleName]
mns :: [ModuleName]
mns = (GenWithIsBoot NodeKey -> Maybe ModuleName)
-> [GenWithIsBoot NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey -> Maybe ModuleName)
-> (GenWithIsBoot NodeKey -> NodeKey)
-> GenWithIsBoot NodeKey
-> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [GenWithIsBoot NodeKey]
deps
[HomeModInfo]
hmis' <- IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo])
-> IO [HomeModInfo] -> ReaderT MakeEnv (MaybeT IO) [HomeModInfo]
forall a b. (a -> b) -> a -> b
$ HscEnv -> [ModuleName] -> IO [HomeModInfo]
rehydrateAfter HscEnv
new_hsc [ModuleName]
mns
[HomeModInfo]
-> [GenWithIsBoot NodeKey] -> ReaderT MakeEnv (MaybeT IO) ()
forall {m :: * -> *}.
Applicative m =>
[HomeModInfo] -> [GenWithIsBoot NodeKey] -> m ()
checkRehydrationInvariant [HomeModInfo]
hmis' [GenWithIsBoot NodeKey]
deps
IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT MakeEnv (MaybeT IO) ())
-> IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a b. (a -> b) -> a -> b
$ MVar (UnitEnvGraph HomeUnitEnv)
-> (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (UnitEnvGraph HomeUnitEnv)
hug_var (\UnitEnvGraph HomeUnitEnv
hug -> UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv))
-> UnitEnvGraph HomeUnitEnv -> IO (UnitEnvGraph HomeUnitEnv)
forall a b. (a -> b) -> a -> b
$ (HomeModInfo
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> [HomeModInfo]
-> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeModInfo -> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
addHomeModInfoToHug UnitEnvGraph HomeUnitEnv
hug [HomeModInfo]
hmis')
return ([HomeModInfo]
hmis', ModuleNameSet
tdeps)
let fanout :: Int -> ResultVar (Maybe HomeModInfo, ModuleNameSet)
fanout Int
i = ([HomeModInfo] -> Maybe HomeModInfo)
-> ([HomeModInfo], ModuleNameSet)
-> (Maybe HomeModInfo, ModuleNameSet)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just (HomeModInfo -> Maybe HomeModInfo)
-> ([HomeModInfo] -> HomeModInfo)
-> [HomeModInfo]
-> Maybe HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([HomeModInfo] -> Int -> HomeModInfo
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)) (([HomeModInfo], ModuleNameSet)
-> (Maybe HomeModInfo, ModuleNameSet))
-> ResultVar ([HomeModInfo], ModuleNameSet)
-> ResultVar (Maybe HomeModInfo, ModuleNameSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Maybe ([HomeModInfo], ModuleNameSet))
-> ResultVar ([HomeModInfo], ModuleNameSet)
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 = (mnkModuleName m) { gwib_isBoot = IsBoot } } )
boot_key NodeKey
k = FilePath -> SDoc -> NodeKey
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"boot_key" (NodeKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr NodeKey
k)
update_module_pipeline :: (GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ()
update_module_pipeline (GenWithIsBoot NodeKey
m, Int
i) =
case GenWithIsBoot NodeKey -> IsBootInterface
forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot GenWithIsBoot NodeKey
m of
IsBootInterface
NotBoot -> NodeKey -> BuildResult -> StateT BuildLoopState IO ()
setModulePipeline (GenWithIsBoot NodeKey -> NodeKey
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 -> StateT BuildLoopState IO ()
setModulePipeline (GenWithIsBoot NodeKey -> NodeKey
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 -> StateT BuildLoopState IO ()
setModulePipeline (NodeKey -> NodeKey
boot_key (GenWithIsBoot NodeKey -> NodeKey
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 = [GenWithIsBoot NodeKey] -> [Int] -> [(GenWithIsBoot NodeKey, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [GenWithIsBoot NodeKey]
deps [Int
0..]
((GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ())
-> [(GenWithIsBoot NodeKey, Int)] -> StateT BuildLoopState IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (GenWithIsBoot NodeKey, Int) -> StateT BuildLoopState IO ()
update_module_pipeline [(GenWithIsBoot NodeKey, Int)]
deps_i
return $ RunMakeM ([HomeModInfo], ModuleNameSet)
-> MVar (Maybe ([HomeModInfo], ModuleNameSet)) -> MakeAction
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 = (HomeModInfo -> ModuleName) -> [HomeModInfo] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (HomeModInfo -> Module) -> HomeModInfo -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis
start :: [ModuleName]
start = (GenWithIsBoot NodeKey -> Maybe ModuleName)
-> [GenWithIsBoot NodeKey] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey -> Maybe ModuleName)
-> (GenWithIsBoot NodeKey -> NodeKey)
-> GenWithIsBoot NodeKey
-> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenWithIsBoot NodeKey -> NodeKey
forall mod. GenWithIsBoot mod -> mod
gwib_mod) [GenWithIsBoot NodeKey]
deps
in Bool -> SDoc -> m ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ([ModuleName]
hmi_names [ModuleName] -> [ModuleName] -> Bool
forall a. Eq a => a -> a -> Bool
== [ModuleName]
start) (SDoc -> m ()) -> SDoc -> m ()
forall a b. (a -> b) -> a -> b
$ ([ModuleName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
hmi_names SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [ModuleName] -> SDoc
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
(MakeEnv -> MakeEnv) -> RunMakeM a -> RunMakeM a
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (\MakeEnv
env -> MakeEnv
env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})
upsweep
:: WorkerLimit
-> HscEnv
-> Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> M.Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, [HomeModInfo])
upsweep :: WorkerLimit
-> HscEnv
-> Maybe ModIfaceCache
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO (SuccessFlag, [HomeModInfo])
upsweep WorkerLimit
n_jobs HscEnv
hsc_env Maybe ModIfaceCache
hmi_cache GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessage Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan = do
(Maybe [ModuleGraphNode]
cycle, [MakeAction]
pipelines, IO [Maybe (Maybe HomeModInfo)]
collect_result) <- UnitEnvGraph HomeUnitEnv
-> Maybe ModIfaceCache
-> Map ModNodeKeyWithUid HomeModInfo
-> [BuildPlan]
-> IO
(Maybe [ModuleGraphNode], [MakeAction],
IO [Maybe (Maybe HomeModInfo)])
interpretBuildPlan (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env) Maybe ModIfaceCache
hmi_cache Map ModNodeKeyWithUid HomeModInfo
old_hpt [BuildPlan]
build_plan
WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runPipelines WorkerLimit
n_jobs HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper 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]
case Maybe [ModuleGraphNode]
cycle of
Just [ModuleGraphNode]
mss -> do
MsgEnvelope GhcMessage -> IO (SuccessFlag, [HomeModInfo])
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO (SuccessFlag, [HomeModInfo]))
-> MsgEnvelope GhcMessage -> IO (SuccessFlag, [HomeModInfo])
forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode] -> MsgEnvelope GhcMessage
cyclicModuleErr [ModuleGraphNode]
mss
Maybe [ModuleGraphNode]
Nothing -> do
let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf ((Maybe (Maybe HomeModInfo) -> Bool)
-> [Maybe (Maybe HomeModInfo)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe (Maybe HomeModInfo) -> Bool
forall a. Maybe a -> Bool
isJust [Maybe (Maybe HomeModInfo)]
res)
(SuccessFlag, [HomeModInfo]) -> IO (SuccessFlag, [HomeModInfo])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (SuccessFlag
success_flag, [HomeModInfo]
completed)
toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
toCache :: [HomeModInfo] -> Map ModNodeKeyWithUid HomeModInfo
toCache [HomeModInfo]
hmis = [(ModNodeKeyWithUid, HomeModInfo)]
-> Map ModNodeKeyWithUid HomeModInfo
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ModIface -> ModNodeKeyWithUid
miKey (ModIface -> ModNodeKeyWithUid) -> ModIface -> ModNodeKeyWithUid
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 (GenUnit UnitId -> UnitId) -> GenUnit UnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit (ModIface -> Module
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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> IO ()) -> Hsc () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe ()) -> Hsc ()
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe ()) -> Hsc ())
-> IO (Messages GhcMessage, Maybe ()) -> Hsc ()
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe ())
-> IO (Messages GhcMessage, Maybe ())
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe ())
-> IO (Messages GhcMessage, Maybe ()))
-> IO (Messages TcRnMessage, Maybe ())
-> IO (Messages GhcMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$ HscEnv -> GenUnit UnitId -> IO (Messages TcRnMessage, Maybe ())
tcRnCheckUnit HscEnv
hsc_env (GenUnit UnitId -> IO (Messages TcRnMessage, Maybe ()))
-> GenUnit UnitId -> IO (Messages TcRnMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> GenUnit UnitId
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 (HomeModInfo -> ModIface) -> Maybe HomeModInfo -> Maybe ModIface
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HomeModInfo
old_hmi) (HomeModLinkable
-> (HomeModInfo -> HomeModLinkable)
-> Maybe HomeModInfo
-> HomeModLinkable
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
| Linkable
linkable <- Maybe Linkable -> [Linkable]
forall a. Maybe a -> [a]
maybeToList Maybe Linkable
mlinkable
, CompiledByteCode
bco <- Linkable -> [CompiledByteCode]
linkableBCOs Linkable
linkable
, SptEntry
spt <- CompiledByteCode -> [SptEntry]
bc_spt_entries CompiledByteCode
bco
]
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 ([ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a]
reverse ([ModuleGraphNode] -> [ModuleGraphNode])
-> [ModuleGraphNode] -> [ModuleGraphNode]
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
= (SCC SummaryNode -> SCC ModuleGraphNode)
-> [SCC SummaryNode] -> [SCC ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map ((SummaryNode -> ModuleGraphNode)
-> SCC SummaryNode -> SCC ModuleGraphNode
forall a b. (a -> b) -> SCC a -> SCC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> ModuleGraphNode
summaryNodeSummary) ([SCC SummaryNode] -> [SCC ModuleGraphNode])
-> [SCC SummaryNode] -> [SCC ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ Graph SummaryNode -> [SCC SummaryNode]
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 (NodeKey -> Maybe SummaryNode) -> NodeKey -> Maybe SummaryNode
forall a b. (a -> b) -> a -> b
$ ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid -> NodeKey) -> ModNodeKeyWithUid -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
root_mod IsBootInterface
NotBoot) UnitId
uid
, Graph SummaryNode
graph Graph SummaryNode -> SummaryNode -> Bool
forall node. Graph node -> node -> Bool
`hasVertexG` SummaryNode
node
= SummaryNode
node
| Bool
otherwise
= GhcException -> SummaryNode
forall a. GhcException -> a
throwGhcException (FilePath -> GhcException
ProgramError FilePath
"module does not exist")
in [SummaryNode] -> Graph SummaryNode
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (SummaryNode -> [SummaryNode] -> [SummaryNode]
forall a b. a -> b -> b
seq SummaryNode
root (Graph SummaryNode -> SummaryNode -> [SummaryNode]
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 -> b) -> ModNodeMap a -> ModNodeMap b)
-> (forall a b. a -> ModNodeMap b -> ModNodeMap a)
-> Functor ModNodeMap
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
$cfmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
fmap :: forall a b. (a -> b) -> ModNodeMap a -> ModNodeMap b
$c<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
<$ :: forall a b. a -> ModNodeMap b -> ModNodeMap a
Functor, Functor ModNodeMap
Foldable ModNodeMap
(Functor ModNodeMap, Foldable ModNodeMap) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b))
-> (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 (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a))
-> Traversable 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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ModNodeMap a -> f (ModNodeMap b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ModNodeMap (f a) -> f (ModNodeMap a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ModNodeMap a -> m (ModNodeMap b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
sequence :: forall (m :: * -> *) a.
Monad m =>
ModNodeMap (m a) -> m (ModNodeMap a)
Traversable, (forall m. Monoid m => ModNodeMap m -> m)
-> (forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m)
-> (forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m)
-> (forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b)
-> (forall a b. (a -> b -> b) -> b -> ModNodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b)
-> (forall a. (a -> a -> a) -> ModNodeMap a -> a)
-> (forall a. (a -> a -> a) -> ModNodeMap a -> a)
-> (forall a. ModNodeMap a -> [a])
-> (forall a. ModNodeMap a -> Bool)
-> (forall a. ModNodeMap a -> Int)
-> (forall a. Eq a => a -> ModNodeMap a -> Bool)
-> (forall a. Ord a => ModNodeMap a -> a)
-> (forall a. Ord a => ModNodeMap a -> a)
-> (forall a. Num a => ModNodeMap a -> a)
-> (forall a. Num a => ModNodeMap a -> a)
-> Foldable ModNodeMap
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
$cfold :: forall m. Monoid m => ModNodeMap m -> m
fold :: forall m. Monoid m => ModNodeMap m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> ModNodeMap a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> ModNodeMap a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
foldl1 :: forall a. (a -> a -> a) -> ModNodeMap a -> a
$ctoList :: forall a. ModNodeMap a -> [a]
toList :: forall a. ModNodeMap a -> [a]
$cnull :: forall a. ModNodeMap a -> Bool
null :: forall a. ModNodeMap a -> Bool
$clength :: forall a. ModNodeMap a -> Int
length :: forall a. ModNodeMap a -> Int
$celem :: forall a. Eq a => a -> ModNodeMap a -> Bool
elem :: forall a. Eq a => a -> ModNodeMap a -> Bool
$cmaximum :: forall a. Ord a => ModNodeMap a -> a
maximum :: forall a. Ord a => ModNodeMap a -> a
$cminimum :: forall a. Ord a => ModNodeMap a -> a
minimum :: forall a. Ord a => ModNodeMap a -> a
$csum :: forall a. Num a => ModNodeMap a -> a
sum :: forall a. Num a => ModNodeMap a -> a
$cproduct :: forall a. Num a => ModNodeMap a -> a
product :: forall a. Num a => ModNodeMap a -> a
Foldable)
emptyModNodeMap :: ModNodeMap a
emptyModNodeMap :: forall a. ModNodeMap a
emptyModNodeMap = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap Map ModuleNameWithIsBoot a
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) = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (ModuleNameWithIsBoot
-> a -> Map ModuleNameWithIsBoot a -> Map ModuleNameWithIsBoot a
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) = Map ModuleNameWithIsBoot a -> [a]
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) = ModuleNameWithIsBoot -> Map ModuleNameWithIsBoot a -> Maybe a
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 = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap (ModuleNameWithIsBoot -> a -> Map ModuleNameWithIsBoot a
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) = Map ModuleNameWithIsBoot a -> ModNodeMap a
forall a. Map ModuleNameWithIsBoot a -> ModNodeMap a
ModNodeMap ((a -> a -> a)
-> Map ModuleNameWithIsBoot a
-> Map ModuleNameWithIsBoot a
-> Map ModuleNameWithIsBoot a
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 (DynFlags -> DiagOpts) -> m DynFlags -> m DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
Opt_WarnUnusedImports DiagOpts
diag_opts) (m () -> m ()) -> m () -> m ()
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 = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
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,
GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan ModuleName
i ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
mods_in_this_cycle ]
warn :: Located ModuleName -> MsgEnvelope GhcMessage
warn :: GenLocated SrcSpan ModuleName -> MsgEnvelope GhcMessage
warn (L SrcSpan
loc ModuleName
mod) = DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts
SrcSpan
loc (ModuleName -> DriverMessage
DriverUnnecessarySourceImports ModuleName
mod)
Messages GhcMessage -> m ()
forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage)
-> Bag (MsgEnvelope GhcMessage) -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope GhcMessage] -> Bag (MsgEnvelope GhcMessage)
forall a. [a] -> Bag a
listToBag ((SCC ModSummary -> [MsgEnvelope GhcMessage])
-> [SCC ModSummary] -> [MsgEnvelope GhcMessage]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ModSummary] -> [MsgEnvelope GhcMessage]
check ([ModSummary] -> [MsgEnvelope GhcMessage])
-> (SCC ModSummary -> [ModSummary])
-> SCC ModSummary
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs))
type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
downsweep :: HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep :: HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [ModSummary]
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots = do
WorkerLimit
n_jobs <- DynFlags -> IO WorkerLimit
mkWorkerLimit (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
([(UnitId, DriverMessages)], [ModSummary])
new <- WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> (HscEnv
-> Target -> IO (Either (UnitId, DriverMessages) ModSummary))
-> IO ([(UnitId, DriverMessages)], [ModSummary])
rootSummariesParallel WorkerLimit
n_jobs HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)
summary
HscEnv
-> Map (UnitId, FilePath) ModSummary
-> [ModuleName]
-> Bool
-> ([(UnitId, DriverMessages)], [ModSummary])
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep_imports HscEnv
hsc_env Map (UnitId, FilePath) ModSummary
old_summary_map [ModuleName]
excl_mods Bool
allow_dup_roots ([(UnitId, DriverMessages)], [ModSummary])
new
where
summary :: HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)
summary = [ModuleName]
-> Map (UnitId, FilePath) ModSummary
-> HscEnv
-> Target
-> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary [ModuleName]
excl_mods Map (UnitId, FilePath) ModSummary
old_summary_map
old_summary_map :: M.Map (UnitId, FilePath) ModSummary
old_summary_map :: Map (UnitId, FilePath) ModSummary
old_summary_map =
[((UnitId, FilePath), ModSummary)]
-> Map (UnitId, FilePath) ModSummary
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]
downsweep_imports :: HscEnv
-> M.Map (UnitId, FilePath) ModSummary
-> [ModuleName]
-> Bool
-> ([(UnitId, DriverMessages)], [ModSummary])
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep_imports :: HscEnv
-> Map (UnitId, FilePath) ModSummary
-> [ModuleName]
-> Bool
-> ([(UnitId, DriverMessages)], [ModSummary])
-> IO ([DriverMessages], [ModuleGraphNode])
downsweep_imports HscEnv
hsc_env Map (UnitId, FilePath) ModSummary
old_summaries [ModuleName]
excl_mods Bool
allow_dup_roots ([(UnitId, DriverMessages)]
root_errs, [ModSummary]
rootSummariesOk)
= do
let root_map :: DownsweepCache
root_map = [ModSummary] -> DownsweepCache
mkRootMap [ModSummary]
rootSummariesOk
DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
(Map NodeKey ModuleGraphNode
deps, DownsweepCache
map0) <- [ModSummary]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [ModSummary]
rootSummariesOk (Map NodeKey ModuleGraphNode
forall k a. Map k a
M.empty, DownsweepCache
root_map)
let closure_errs :: [DriverMessages]
closure_errs = UnitEnv -> [DriverMessages]
checkHomeUnitsClosed UnitEnv
unit_env
unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
downsweep_errs :: [DriverMessages]
downsweep_errs = [Either DriverMessages ModSummary] -> [DriverMessages]
forall a b. [Either a b] -> [a]
lefts ([Either DriverMessages ModSummary] -> [DriverMessages])
-> [Either DriverMessages ModSummary] -> [DriverMessages]
forall a b. (a -> b) -> a -> b
$ [[Either DriverMessages ModSummary]]
-> [Either DriverMessages ModSummary]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either DriverMessages ModSummary]]
-> [Either DriverMessages ModSummary])
-> [[Either DriverMessages ModSummary]]
-> [Either DriverMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ DownsweepCache -> [[Either DriverMessages ModSummary]]
forall k a. Map k a -> [a]
M.elems DownsweepCache
map0
downsweep_nodes :: [ModuleGraphNode]
downsweep_nodes = Map NodeKey ModuleGraphNode -> [ModuleGraphNode]
forall k a. Map k a -> [a]
M.elems Map NodeKey ModuleGraphNode
deps
([DriverMessages]
other_errs, [ModuleGraphNode]
unit_nodes) = [Either DriverMessages ModuleGraphNode]
-> ([DriverMessages], [ModuleGraphNode])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either DriverMessages ModuleGraphNode]
-> ([DriverMessages], [ModuleGraphNode]))
-> [Either DriverMessages ModuleGraphNode]
-> ([DriverMessages], [ModuleGraphNode])
forall a b. (a -> b) -> a -> b
$ ([Either DriverMessages ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> [Either DriverMessages ModuleGraphNode])
-> [Either DriverMessages ModuleGraphNode]
-> UnitEnvGraph HomeUnitEnv
-> [Either DriverMessages ModuleGraphNode]
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 [Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
-> UnitId -> HomeUnitEnv -> [Either DriverMessages ModuleGraphNode]
unitModuleNodes [ModuleGraphNode]
downsweep_nodes UnitId
uid HomeUnitEnv
hue) [] (HscEnv -> UnitEnvGraph HomeUnitEnv
hsc_HUG HscEnv
hsc_env)
all_nodes :: [ModuleGraphNode]
all_nodes = [ModuleGraphNode]
downsweep_nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphNode]
unit_nodes
all_errs :: [DriverMessages]
all_errs = [DriverMessages]
all_root_errs [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessages]
downsweep_errs [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ [DriverMessages]
other_errs
all_root_errs :: [DriverMessages]
all_root_errs = [DriverMessages]
closure_errs [DriverMessages] -> [DriverMessages] -> [DriverMessages]
forall a. [a] -> [a] -> [a]
++ ((UnitId, DriverMessages) -> DriverMessages)
-> [(UnitId, DriverMessages)] -> [DriverMessages]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, DriverMessages) -> DriverMessages
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 [DriverMessages] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DriverMessages]
all_root_errs
then ([DriverMessages], [ModuleGraphNode])
-> IO ([DriverMessages], [ModuleGraphNode])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DriverMessages]
all_errs, [ModuleGraphNode]
th_enabled_nodes)
else ([DriverMessages], [ModuleGraphNode])
-> IO ([DriverMessages], [ModuleGraphNode])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([DriverMessages], [ModuleGraphNode])
-> IO ([DriverMessages], [ModuleGraphNode]))
-> ([DriverMessages], [ModuleGraphNode])
-> IO ([DriverMessages], [ModuleGraphNode])
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 (ModuleGraphNode -> Either DriverMessages ModuleGraphNode)
-> [ModuleGraphNode] -> [Either DriverMessages ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> Either DriverMessages ModuleGraphNode
forall a b. b -> Either a b
Right [ModuleGraphNode]
instantiation_nodes
[Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
-> [Either DriverMessages ModuleGraphNode]
forall a. [a] -> [a] -> [a]
++ Maybe (Either DriverMessages ModuleGraphNode)
-> [Either DriverMessages ModuleGraphNode]
forall a. Maybe a -> [a]
maybeToList ([ModuleGraphNode]
-> UnitId
-> HomeUnitEnv
-> Maybe (Either DriverMessages ModuleGraphNode)
linkNodes ([ModuleGraphNode]
instantiation_nodes [ModuleGraphNode] -> [ModuleGraphNode] -> [ModuleGraphNode]
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, GenLocated SrcSpan ModuleName
-> IsBootInterface -> GenWithIsBoot (GenLocated SrcSpan ModuleName)
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName -> GenLocated SrcSpan ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
IsBoot) | IsBootInterface
NotBoot <- [ModSummary -> IsBootInterface
isBootSummary ModSummary
ms] ] [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
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
checkDuplicates
:: DownsweepCache
-> IO ()
checkDuplicates :: DownsweepCache -> IO ()
checkDuplicates DownsweepCache
root_map
| Bool
allow_dup_roots = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| [[ModSummary]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModSummary]]
dup_roots = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [ModSummary] -> IO ()
multiRootsErr ([[ModSummary]] -> [ModSummary]
forall a. HasCallStack => [a] -> a
head [[ModSummary]]
dup_roots)
where
dup_roots :: [[ModSummary]]
dup_roots :: [[ModSummary]]
dup_roots = ([ModSummary] -> Bool) -> [[ModSummary]] -> [[ModSummary]]
forall a. (a -> Bool) -> [a] -> [a]
filterOut [ModSummary] -> Bool
forall a. [a] -> Bool
isSingleton ([[ModSummary]] -> [[ModSummary]])
-> [[ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> a -> b
$ ([Either DriverMessages ModSummary] -> [ModSummary])
-> [[Either DriverMessages ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> [a] -> [b]
map [Either DriverMessages ModSummary] -> [ModSummary]
forall a b. [Either a b] -> [b]
rights (DownsweepCache -> [[Either DriverMessages ModSummary]]
forall k a. Map k a -> [a]
M.elems DownsweepCache
root_map)
loopSummaries :: [ModSummary]
-> (M.Map NodeKey ModuleGraphNode,
DownsweepCache)
-> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
loopSummaries :: [ModSummary]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [] (Map NodeKey ModuleGraphNode, DownsweepCache)
done = (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map NodeKey ModuleGraphNode, DownsweepCache)
done
loopSummaries (ModSummary
ms:[ModSummary]
next) (Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
| Just {} <- NodeKey -> Map NodeKey ModuleGraphNode -> Maybe ModuleGraphNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeKey
k Map NodeKey ModuleGraphNode
done
= [ModSummary]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [ModSummary]
next (Map NodeKey ModuleGraphNode
done, DownsweepCache
summarised)
| Bool
otherwise = do
([NodeKey]
final_deps, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports (ModSummary
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
calcDeps ModSummary
ms) Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey]
_, Map NodeKey ModuleGraphNode
done'', DownsweepCache
summarised'') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports (Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
-> [(UnitId, PkgQual,
GenWithIsBoot (GenLocated SrcSpan ModuleName))]
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, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [ModSummary]
next (NodeKey
-> ModuleGraphNode
-> Map NodeKey ModuleGraphNode
-> Map NodeKey ModuleGraphNode
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'', 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
= (UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
-> Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
forall a. a -> Maybe a
Just ((UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
-> Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName)))
-> (UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
-> Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
forall a b. (a -> b) -> a -> b
$ ((ModSummary -> UnitId
ms_unitid ModSummary
ms), PkgQual
NoPkgQual, (GenLocated SrcSpan ModuleName
-> IsBootInterface -> GenWithIsBoot (GenLocated SrcSpan ModuleName)
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName -> GenLocated SrcSpan ModuleName
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModuleName
ms_mod_name ModSummary
ms) IsBootInterface
NotBoot))
| Bool
otherwise
= Maybe
(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))
forall a. Maybe a
Nothing
loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-> M.Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey],
M.Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports :: [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [] Map NodeKey ModuleGraphNode
done DownsweepCache
summarised = ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], 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 <- (UnitId, PkgQual, ModuleNameWithIsBoot)
-> DownsweepCache -> Maybe [Either DriverMessages ModSummary]
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, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeKey
nkNodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
rest, Map NodeKey ModuleGraphNode
summarised', DownsweepCache
done')
[Left DriverMessages
_err] ->
[(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], 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], 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 (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summaries
IsBootInterface
is_boot GenLocated SrcSpan ModuleName
wanted_mod PkgQual
mb_pkg
Maybe (StringBuffer, UTCTime)
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], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
External UnitId
_ -> do
([NodeKey]
other_deps, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NodeKey]
other_deps, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
FoundInstantiation InstantiatedUnit
iud -> do
([NodeKey]
other_deps, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done DownsweepCache
summarised
([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
iud NodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised')
FoundHomeWithError (UnitId
_uid, DriverMessages
e) -> [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done ((UnitId, PkgQual, ModuleNameWithIsBoot)
-> [Either DriverMessages ModSummary]
-> DownsweepCache
-> DownsweepCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [(DriverMessages -> Either DriverMessages ModSummary
forall a b. a -> Either a b
Left DriverMessages
e)] DownsweepCache
summarised)
FoundHome ModSummary
s -> do
(Map NodeKey ModuleGraphNode
done', DownsweepCache
summarised') <-
[ModSummary]
-> (Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO (Map NodeKey ModuleGraphNode, DownsweepCache)
loopSummaries [ModSummary
s] (Map NodeKey ModuleGraphNode
done, (UnitId, PkgQual, ModuleNameWithIsBoot)
-> [Either DriverMessages ModSummary]
-> DownsweepCache
-> DownsweepCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key [ModSummary -> Either DriverMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s] DownsweepCache
summarised)
([NodeKey]
other_deps, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised) <- [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
-> Map NodeKey ModuleGraphNode
-> DownsweepCache
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
loopImports [(UnitId, PkgQual, GenWithIsBoot (GenLocated SrcSpan ModuleName))]
ss Map NodeKey ModuleGraphNode
done' DownsweepCache
summarised'
([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
-> IO ([NodeKey], Map NodeKey ModuleGraphNode, DownsweepCache)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModSummary -> ModNodeKeyWithUid
msKey ModSummary
s) NodeKey -> [NodeKey] -> [NodeKey]
forall a. a -> [a] -> [a]
: [NodeKey]
other_deps, Map NodeKey ModuleGraphNode
final_done, DownsweepCache
final_summarised)
where
cache_key :: (UnitId, PkgQual, ModuleNameWithIsBoot)
cache_key = (UnitId
home_uid, PkgQual
mb_pkg, GenLocated SrcSpan ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan ModuleName -> ModuleName)
-> GenWithIsBoot (GenLocated SrcSpan ModuleName)
-> ModuleNameWithIsBoot
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 = SrcSpan -> ModuleName -> GenLocated SrcSpan ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc ModuleName
mod
getRootSummary ::
[ModuleName] ->
M.Map (UnitId, FilePath) ModSummary ->
HscEnv ->
Target ->
IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary :: [ModuleName]
-> Map (UnitId, FilePath) ModSummary
-> HscEnv
-> Target
-> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary [ModuleName]
excl_mods Map (UnitId, FilePath) ModSummary
old_summary_map HscEnv
hsc_env Target
target
| TargetFile FilePath
file Maybe Phase
mb_phase <- TargetId
targetId
= do
let offset_file :: FilePath
offset_file = DynFlags -> FilePath -> FilePath
augmentByWorkingDirectory DynFlags
dflags FilePath
file
Bool
exists <- IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
offset_file
if Bool
exists Bool -> Bool -> Bool
|| Maybe (StringBuffer, UTCTime) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (StringBuffer, UTCTime)
maybe_buf
then (DriverMessages -> (UnitId, DriverMessages))
-> Either DriverMessages ModSummary
-> Either (UnitId, DriverMessages) ModSummary
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (UnitId
uid,) (Either DriverMessages ModSummary
-> Either (UnitId, DriverMessages) ModSummary)
-> IO (Either DriverMessages ModSummary)
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, 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 (StringBuffer, UTCTime)
maybe_buf
else
Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary))
-> Either (UnitId, DriverMessages) ModSummary
-> IO (Either (UnitId, DriverMessages) ModSummary)
forall a b. (a -> b) -> a -> b
$ (UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. a -> Either a b
Left ((UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary)
-> (UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. (a -> b) -> a -> b
$ (UnitId
uid,) (DriverMessages -> (UnitId, DriverMessages))
-> DriverMessages -> (UnitId, DriverMessages)
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$
SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (FilePath -> DriverMessage
DriverFileNotFound FilePath
offset_file)
| TargetModule ModuleName
modl <- TargetId
targetId
= do
SummariseResult
maybe_summary <- HscEnv
-> HomeUnit
-> Map (UnitId, FilePath) ModSummary
-> IsBootInterface
-> GenLocated SrcSpan ModuleName
-> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO SummariseResult
summariseModule HscEnv
hsc_env HomeUnit
home_unit Map (UnitId, FilePath) ModSummary
old_summary_map IsBootInterface
NotBoot
(SrcSpan -> ModuleName -> GenLocated SrcSpan ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) (UnitId -> PkgQual
ThisPkg (HomeUnit -> UnitId
forall u. GenHomeUnit u -> UnitId
homeUnitId HomeUnit
home_unit))
Maybe (StringBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
pure case SummariseResult
maybe_summary of
FoundHome ModSummary
s -> ModSummary -> Either (UnitId, DriverMessages) ModSummary
forall a b. b -> Either a b
Right ModSummary
s
FoundHomeWithError (UnitId, DriverMessages)
err -> (UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. a -> Either a b
Left (UnitId, DriverMessages)
err
SummariseResult
_ -> (UnitId, DriverMessages)
-> Either (UnitId, DriverMessages) ModSummary
forall a b. a -> Either a b
Left (UnitId
uid, ModuleName -> DriverMessages
moduleNotFoundErr ModuleName
modl)
where
Target {TargetId
targetId :: Target -> TargetId
targetId :: TargetId
targetId, targetContents :: Target -> Maybe (StringBuffer, UTCTime)
targetContents = Maybe (StringBuffer, UTCTime)
maybe_buf, targetUnitId :: Target -> UnitId
targetUnitId = UnitId
uid} = Target
target
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>")
dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
UnitId -> UnitEnv -> HomeUnitEnv
ue_findHomeUnitEnv UnitId
uid (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))
rootSummariesParallel ::
WorkerLimit ->
HscEnv ->
(GhcMessage -> AnyGhcDiagnostic) ->
Maybe Messager ->
(HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)) ->
IO ([(UnitId, DriverMessages)], [ModSummary])
rootSummariesParallel :: WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> (HscEnv
-> Target -> IO (Either (UnitId, DriverMessages) ModSummary))
-> IO ([(UnitId, DriverMessages)], [ModSummary])
rootSummariesParallel WorkerLimit
n_jobs HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)
get_summary = do
([MakeAction]
actions, [IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))]
get_results) <- [(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))]
-> ([MakeAction],
[IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))]
-> ([MakeAction],
[IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))]))
-> IO
[(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))]
-> IO
([MakeAction],
[IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, [Target])
-> IO
(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))))
-> [(Int, [Target])]
-> IO
[(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, [Target])
-> IO
(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
action_and_result ([Int] -> [[Target]] -> [(Int, [Target])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [[Target]]
bundles)
WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runPipelines WorkerLimit
n_jobs HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
msg [MakeAction]
actions
([Either SomeException [Either (UnitId, DriverMessages) ModSummary]]
-> Either
SomeException [[Either (UnitId, DriverMessages) ModSummary]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Either
SomeException [Either (UnitId, DriverMessages) ModSummary]]
-> Either
SomeException [[Either (UnitId, DriverMessages) ModSummary]])
-> ([Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])]
-> [Either
SomeException [Either (UnitId, DriverMessages) ModSummary]])
-> [Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])]
-> Either
SomeException [[Either (UnitId, DriverMessages) ModSummary]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])]
-> [Either
SomeException [Either (UnitId, DriverMessages) ModSummary]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])]
-> Either
SomeException [[Either (UnitId, DriverMessages) ModSummary]])
-> IO
[Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])]
-> IO
(Either
SomeException [[Either (UnitId, DriverMessages) ModSummary]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))]
-> IO
[Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))]
get_results) IO
(Either
SomeException [[Either (UnitId, DriverMessages) ModSummary]])
-> (Either
SomeException [[Either (UnitId, DriverMessages) ModSummary]]
-> IO ([(UnitId, DriverMessages)], [ModSummary]))
-> IO ([(UnitId, DriverMessages)], [ModSummary])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right [[Either (UnitId, DriverMessages) ModSummary]]
results -> ([(UnitId, DriverMessages)], [ModSummary])
-> IO ([(UnitId, DriverMessages)], [ModSummary])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either (UnitId, DriverMessages) ModSummary]
-> ([(UnitId, DriverMessages)], [ModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([[Either (UnitId, DriverMessages) ModSummary]]
-> [Either (UnitId, DriverMessages) ModSummary]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Either (UnitId, DriverMessages) ModSummary]]
results))
Left SomeException
exc -> SomeException -> IO ([(UnitId, DriverMessages)], [ModSummary])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exc
where
bundles :: [[Target]]
bundles = [Target] -> [[Target]]
mk_bundles [Target]
targets
mk_bundles :: [Target] -> [[Target]]
mk_bundles = ([Target] -> Maybe ([Target], [Target])) -> [Target] -> [[Target]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr \case
[] -> Maybe ([Target], [Target])
forall a. Maybe a
Nothing
[Target]
ts -> ([Target], [Target]) -> Maybe ([Target], [Target])
forall a. a -> Maybe a
Just (Int -> [Target] -> ([Target], [Target])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
bundle_size [Target]
ts)
bundle_size :: Int
bundle_size = Int
20
targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
action_and_result :: (Int, [Target])
-> IO
(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
action_and_result (Int
log_queue_id, [Target]
ts) = do
MVar
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
res_var <- IO
(MVar
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
-> IO
(MVar
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO
(MVar
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
forall a. IO (MVar a)
newEmptyMVar
(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
-> IO
(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
-> IO
(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))))
-> (MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
-> IO
(MakeAction,
IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary])))
forall a b. (a -> b) -> a -> b
$! (RunMakeM
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> MVar
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
-> MakeAction
forall a. RunMakeM a -> MVar (Maybe a) -> MakeAction
MakeAction (Int
-> [Target]
-> RunMakeM
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
action Int
log_queue_id [Target]
ts) MVar
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
res_var, MVar
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
-> IO
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
forall a. MVar a -> IO a
readMVar MVar
(Maybe
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
res_var)
action :: Int
-> [Target]
-> RunMakeM
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
action Int
log_queue_id [Target]
target_bundle = do
env :: MakeEnv
env@MakeEnv {AbstractSem
compile_sem :: MakeEnv -> AbstractSem
compile_sem :: AbstractSem
compile_sem} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
MaybeT
IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> RunMakeM
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT
IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> RunMakeM
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
-> MaybeT
IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> RunMakeM
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall a b. (a -> b) -> a -> b
$ IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> MaybeT
IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> MaybeT
IO
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> MaybeT
IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall a b. (a -> b) -> a -> b
$
AbstractSem
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem (IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> IO
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall a b. (a -> b) -> a -> b
$
Int
-> MakeEnv
-> (HscEnv
-> IO
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
log_queue_id MakeEnv
env \ HscEnv
lcl_hsc_env ->
IO [Either (UnitId, DriverMessages) ModSummary]
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try ((Target -> IO (Either (UnitId, DriverMessages) ModSummary))
-> [Target] -> IO [Either (UnitId, DriverMessages) ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)
get_summary HscEnv
lcl_hsc_env) [Target]
target_bundle) IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
-> (Either
SomeException [Either (UnitId, DriverMessages) ModSummary]
-> IO
(Either
SomeException [Either (UnitId, DriverMessages) ModSummary]))
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left SomeException
e | Just (SomeAsyncException
_ :: SomeAsyncException) <- SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e ->
SomeException
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
Either SomeException [Either (UnitId, DriverMessages) ModSummary]
a -> Either SomeException [Either (UnitId, DriverMessages) ModSummary]
-> IO
(Either SomeException [Either (UnitId, DriverMessages) ModSummary])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SomeException [Either (UnitId, DriverMessages) ModSummary]
a
checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
checkHomeUnitsClosed UnitEnv
ue
| Set UnitId -> Bool
forall a. Set a -> Bool
Set.null Set UnitId
bad_unit_ids = []
| Bool
otherwise = [MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
rootLoc (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ [UnitId] -> DriverMessage
DriverHomePackagesNotClosed (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
bad_unit_ids)]
where
home_id_set :: Set UnitId
home_id_set = UnitEnvGraph HomeUnitEnv -> Set UnitId
forall v. UnitEnvGraph v -> Set UnitId
unitEnv_keys (UnitEnvGraph HomeUnitEnv -> Set UnitId)
-> UnitEnvGraph HomeUnitEnv -> Set UnitId
forall a b. (a -> b) -> a -> b
$ UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph UnitEnv
ue
bad_unit_ids :: Set UnitId
bad_unit_ids = Set UnitId
upwards_closure Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set UnitId
home_id_set
rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
fsLit FilePath
"<command line>")
graph :: Graph (Node UnitId UnitId)
graph :: Graph (Node UnitId UnitId)
graph = [Node UnitId UnitId] -> Graph (Node UnitId UnitId)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [Node UnitId UnitId]
graphNodes
downwards_closure :: Graph (Node UnitId UnitId)
downwards_closure
= [Node UnitId UnitId] -> Graph (Node UnitId UnitId)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [ UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
deps)
| (UnitId
uid, Set UnitId
deps) <- Map UnitId (Set UnitId) -> [(UnitId, Set UnitId)]
forall k a. Map k a -> [(k, a)]
M.toList (Graph (Node UnitId UnitId)
-> (Node UnitId UnitId -> UnitId) -> Map UnitId (Set UnitId)
forall key node.
Ord key =>
Graph node -> (node -> key) -> Map key (Set key)
allReachable Graph (Node UnitId UnitId)
graph Node UnitId UnitId -> UnitId
forall key payload. Node key payload -> key
node_key)]
inverse_closure :: Graph (Node UnitId UnitId)
inverse_closure = Graph (Node UnitId UnitId) -> Graph (Node UnitId UnitId)
forall node. Graph node -> Graph node
transposeG Graph (Node UnitId UnitId)
downwards_closure
upwards_closure :: Set UnitId
upwards_closure = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> Set UnitId) -> [UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ (Node UnitId UnitId -> UnitId) -> [Node UnitId UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Node UnitId UnitId -> UnitId
forall key payload. Node key payload -> key
node_key ([Node UnitId UnitId] -> [UnitId])
-> [Node UnitId UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ Graph (Node UnitId UnitId)
-> [Node UnitId UnitId] -> [Node UnitId UnitId]
forall node. Graph node -> [node] -> [node]
reachablesG Graph (Node UnitId UnitId)
inverse_closure [UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid [] | UnitId
uid <- Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
home_id_set]
all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
all_unit_direct_deps :: UniqMap UnitId (Set UnitId)
all_unit_direct_deps
= (UniqMap UnitId (Set UnitId)
-> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId))
-> UniqMap UnitId (Set UnitId)
-> UnitEnvGraph HomeUnitEnv
-> UniqMap UnitId (Set UnitId)
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey UniqMap UnitId (Set UnitId)
-> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId)
go UniqMap UnitId (Set UnitId)
forall k a. UniqMap k a
emptyUniqMap (UnitEnvGraph HomeUnitEnv -> UniqMap UnitId (Set UnitId))
-> UnitEnvGraph HomeUnitEnv -> UniqMap UnitId (Set UnitId)
forall a b. (a -> b) -> a -> b
$ UnitEnv -> UnitEnvGraph HomeUnitEnv
ue_home_unit_graph UnitEnv
ue
where
go :: UniqMap UnitId (Set UnitId)
-> UnitId -> HomeUnitEnv -> UniqMap UnitId (Set UnitId)
go UniqMap UnitId (Set UnitId)
rest UnitId
this HomeUnitEnv
this_uis =
(Set UnitId -> Set UnitId -> Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UniqMap UnitId (Set UnitId)
forall a k.
(a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
plusUniqMap_C Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.union
((Set UnitId -> Set UnitId -> Set UnitId)
-> UniqMap UnitId (Set UnitId)
-> UnitId
-> Set UnitId
-> UniqMap UnitId (Set UnitId)
forall k a.
Uniquable k =>
(a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap_C Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.union UniqMap UnitId (Set UnitId)
external_depends UnitId
this ([UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> Set UnitId) -> [UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ [UnitId]
this_deps))
UniqMap UnitId (Set UnitId)
rest
where
external_depends :: UniqMap UnitId (Set UnitId)
external_depends = (UnitInfo -> Set UnitId)
-> UniqMap UnitId UnitInfo -> UniqMap UnitId (Set UnitId)
forall a b k. (a -> b) -> UniqMap k a -> UniqMap k b
mapUniqMap ([UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ([UnitId] -> Set UnitId)
-> (UnitInfo -> [UnitId]) -> UnitInfo -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends) (UnitState -> UniqMap UnitId UnitInfo
unitInfoMap UnitState
this_units)
this_units :: UnitState
this_units = HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
this_uis
this_deps :: [UnitId]
this_deps = [ GenUnit UnitId -> UnitId
toUnitId GenUnit UnitId
unit | (GenUnit UnitId
unit,Just PackageArg
_) <- UnitState -> [(GenUnit UnitId, Maybe PackageArg)]
explicitUnits UnitState
this_units]
graphNodes :: [Node UnitId UnitId]
graphNodes :: [Node UnitId UnitId]
graphNodes = Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
forall a. Set a
Set.empty Set UnitId
home_id_set
where
go :: Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
done Set UnitId
todo
= case Set UnitId -> Maybe (UnitId, Set UnitId)
forall a. Set a -> Maybe (a, Set a)
Set.minView Set UnitId
todo of
Maybe (UnitId, Set UnitId)
Nothing -> []
Just (UnitId
uid, Set UnitId
todo')
| UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member UnitId
uid Set UnitId
done -> Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go Set UnitId
done Set UnitId
todo'
| Bool
otherwise -> case UniqMap UnitId (Set UnitId) -> UnitId -> Maybe (Set UnitId)
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap UnitId (Set UnitId)
all_unit_direct_deps UnitId
uid of
Maybe (Set UnitId)
Nothing -> FilePath -> SDoc -> [Node UnitId UnitId]
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"uid not found" ((UnitId, UniqMap UnitId (Set UnitId)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId
uid, UniqMap UnitId (Set UnitId)
all_unit_direct_deps))
Just Set UnitId
depends ->
let todo'' :: Set UnitId
todo'' = (Set UnitId
depends Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set UnitId
done) Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set UnitId
todo'
in UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
depends) Node UnitId UnitId -> [Node UnitId UnitId] -> [Node UnitId UnitId]
forall a. a -> [a] -> [a]
: Set UnitId -> Set UnitId -> [Node UnitId UnitId]
go (UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
done) Set UnitId
todo''
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
(CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool) -> Eq CodeGenEnable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CodeGenEnable -> CodeGenEnable -> Bool
== :: CodeGenEnable -> CodeGenEnable -> Bool
$c/= :: CodeGenEnable -> CodeGenEnable -> Bool
/= :: CodeGenEnable -> CodeGenEnable -> Bool
Eq, Int -> CodeGenEnable -> FilePath -> FilePath
[CodeGenEnable] -> FilePath -> FilePath
CodeGenEnable -> FilePath
(Int -> CodeGenEnable -> FilePath -> FilePath)
-> (CodeGenEnable -> FilePath)
-> ([CodeGenEnable] -> FilePath -> FilePath)
-> Show CodeGenEnable
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> CodeGenEnable -> FilePath -> FilePath
showsPrec :: Int -> CodeGenEnable -> FilePath -> FilePath
$cshow :: CodeGenEnable -> FilePath
show :: CodeGenEnable -> FilePath
$cshowList :: [CodeGenEnable] -> FilePath -> FilePath
showList :: [CodeGenEnable] -> FilePath -> FilePath
Show, Eq CodeGenEnable
Eq CodeGenEnable =>
(CodeGenEnable -> CodeGenEnable -> Ordering)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> Bool)
-> (CodeGenEnable -> CodeGenEnable -> CodeGenEnable)
-> (CodeGenEnable -> CodeGenEnable -> CodeGenEnable)
-> Ord 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
$ccompare :: CodeGenEnable -> CodeGenEnable -> Ordering
compare :: CodeGenEnable -> CodeGenEnable -> Ordering
$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
>= :: CodeGenEnable -> CodeGenEnable -> Bool
$cmax :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
max :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
$cmin :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
min :: CodeGenEnable -> CodeGenEnable -> CodeGenEnable
Ord)
instance Outputable CodeGenEnable where
ppr :: CodeGenEnable -> SDoc
ppr = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc)
-> (CodeGenEnable -> FilePath) -> CodeGenEnable -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenEnable -> FilePath
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 =
(ModuleGraphNode -> IO ModuleGraphNode)
-> [ModuleGraphNode] -> IO [ModuleGraphNode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen [ModuleGraphNode]
mod_graph
where
defaultBackendOf :: ModSummary -> Backend
defaultBackendOf ModSummary
ms = Platform -> Backend
platformDefaultBackend (DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> DynFlags -> Platform
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitId -> UnitEnv -> DynFlags
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 NodeKey -> Map NodeKey CodeGenEnable -> Maybe CodeGenEnable
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 (OsString, OsString)
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 (HasCallStack => FilePath -> OsString
FilePath -> OsString
unsafeEncodeUtf FilePath
tn, HasCallStack => FilePath -> OsString
FilePath -> OsString
unsafeEncodeUtf FilePath
dyn_tn)
((OsString
hi_file, OsString
dyn_hi_file), (OsString
o_file, OsString
dyn_o_file)) <-
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
then ((OsString, OsString), (OsString, OsString))
-> IO ((OsString, OsString), (OsString, OsString))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModLocation -> OsString
ml_hi_file_ospath ModLocation
ms_location, ModLocation -> OsString
ml_dyn_hi_file_ospath ModLocation
ms_location)
, (ModLocation -> OsString
ml_obj_file_ospath ModLocation
ms_location, ModLocation -> OsString
ml_dyn_obj_file_ospath ModLocation
ms_location))
else (,) ((OsString, OsString)
-> (OsString, OsString)
-> ((OsString, OsString), (OsString, OsString)))
-> IO (OsString, OsString)
-> IO
((OsString, OsString)
-> ((OsString, OsString), (OsString, OsString)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> FilePath -> IO (OsString, OsString)
new_temp_file (DynFlags -> FilePath
hiSuf_ DynFlags
dflags) (DynFlags -> FilePath
dynHiSuf_ DynFlags
dflags))
IO
((OsString, OsString)
-> ((OsString, OsString), (OsString, OsString)))
-> IO (OsString, OsString)
-> IO ((OsString, OsString), (OsString, OsString))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> FilePath -> IO (OsString, OsString)
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 = interpreterBackend }
CodeGenEnable
EnableObject -> DynFlags
dflags { backend = defaultBackendOf ms }
CodeGenEnable
EnableByteCodeAndObject -> (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
let ms' :: ModSummary
ms' = ModSummary
ms
{ ms_location =
ms_location { ml_hi_file_ospath = hi_file
, ml_obj_file_ospath = o_file
, ml_dyn_hi_file_ospath = dyn_hi_file
, ml_dyn_obj_file_ospath = dyn_o_file }
, ms_hspp_opts = updOptLevel 0 $ 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 = gopt_set (ms_hspp_opts ms) 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 = gopt_set (ms_hspp_opts ms) 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 = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter
}
ModuleGraphNode -> IO ModuleGraphNode
enable_code_gen ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [NodeKey]
deps ModSummary
ms')
| Bool
otherwise -> ModuleGraphNode -> IO ModuleGraphNode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraphNode
n
enable_code_gen ModuleGraphNode
ms = ModuleGraphNode -> IO ModuleGraphNode
forall a. a -> IO a
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
&&
HomeUnit -> 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
| Settings -> Bool
sTargetRTSLinkerOnlySupportsSharedLibs (Settings -> Bool) -> Settings -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Settings
settings DynFlags
lcl_dflags =
Bool -> Bool
not Bool
isDynWay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
dyn_too_enabled
Bool -> Bool -> Bool
&& Bool
enable_object
| Bool
otherwise =
Bool
hostIsDynamic Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hostIsProfiled 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 = [NodeKey] -> Set NodeKey
forall a. Ord a => [a] -> Set a
Set.fromList ([NodeKey] -> Set NodeKey) -> [NodeKey] -> Set NodeKey
forall a b. (a -> b) -> a -> b
$ (SummaryNode -> NodeKey) -> [SummaryNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleGraphNode -> NodeKey
mkNodeKey (ModuleGraphNode -> NodeKey)
-> (SummaryNode -> ModuleGraphNode) -> SummaryNode -> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SummaryNode -> ModuleGraphNode
forall key payload. Node key payload -> payload
node_payload) ([SummaryNode] -> [NodeKey]) -> [SummaryNode] -> [NodeKey]
forall a b. (a -> b) -> a -> b
$ Graph SummaryNode -> [SummaryNode] -> [SummaryNode]
forall node. Graph node -> [node] -> [node]
reachablesG Graph SummaryNode
mg ((NodeKey -> SummaryNode) -> [NodeKey] -> [SummaryNode]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe SummaryNode -> SummaryNode
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"needs_th" (Maybe SummaryNode -> SummaryNode)
-> (NodeKey -> Maybe SummaryNode) -> NodeKey -> SummaryNode
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 =
(CodeGenEnable -> CodeGenEnable -> CodeGenEnable)
-> Map NodeKey CodeGenEnable
-> Map NodeKey CodeGenEnable
-> Map NodeKey CodeGenEnable
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\CodeGenEnable
_ CodeGenEnable
_ -> CodeGenEnable
EnableByteCodeAndObject)
([(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable)
-> [(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable
forall a b. (a -> b) -> a -> b
$ [(NodeKey
m, CodeGenEnable
EnableObject) | NodeKey
m <- Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
needs_obj_set])
([(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable)
-> [(NodeKey, CodeGenEnable)] -> Map NodeKey CodeGenEnable
forall a b. (a -> b) -> a -> b
$ [(NodeKey
m, CodeGenEnable
EnableByteCode) | NodeKey
m <- Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
Set.toList Set NodeKey
needs_bc_set])
need_obj_set :: [NodeKey]
need_obj_set =
[[NodeKey]] -> [NodeKey]
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 =
[[NodeKey]] -> [NodeKey]
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 = ([Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary])
-> [((UnitId, PkgQual, ModuleNameWithIsBoot),
[Either DriverMessages ModSummary])]
-> DownsweepCache
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary])
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
-> [Either DriverMessages ModSummary]
forall a. [a] -> [a] -> [a]
(++))
[ ((ModSummary -> UnitId
ms_unitid ModSummary
s, PkgQual
NoPkgQual, ModSummary -> ModuleNameWithIsBoot
ms_mnwib ModSummary
s), [ModSummary -> Either DriverMessages ModSummary
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 (StringBuffer, 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 (StringBuffer, UTCTime)
maybe_buf
| Just ModSummary
old_summary <- (UnitId, FilePath)
-> Map (UnitId, FilePath) ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (HomeUnit -> UnitId
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 (ModSummary -> ModLocation) -> ModSummary -> ModLocation
forall a b. (a -> b) -> a -> b
$ ModSummary
old_summary
Fingerprint
src_hash <- IO Fingerprint
get_src_hash
HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
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
HomeUnit -> HscEnv -> HscEnv
hscSetActiveHomeUnit HomeUnit
home_unit HscEnv
hsc_env'
get_src_hash :: IO Fingerprint
get_src_hash = case Maybe (StringBuffer, UTCTime)
maybe_buf of
Just (StringBuffer
buf,UTCTime
_) -> Fingerprint -> IO Fingerprint
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> IO Fingerprint) -> Fingerprint -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ StringBuffer -> Fingerprint
fingerprintStringBuffer StringBuffer
buf
Maybe (StringBuffer, UTCTime)
Nothing -> IO Fingerprint -> IO Fingerprint
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> IO Fingerprint)
-> IO Fingerprint -> IO Fingerprint
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 = ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary))
-> ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
ModuleName
StringBuffer
SrcSpan
DynFlags
pi_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: Bool
pi_hspp_fn :: FilePath
pi_hspp_buf :: StringBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> StringBuffer
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 (StringBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (StringBuffer, UTCTime)
maybe_buf
let fopts :: FinderOpts
fopts = DynFlags -> FinderOpts
initFinderOpts (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
src_path :: OsString
src_path = HasCallStack => FilePath -> OsString
FilePath -> OsString
unsafeEncodeUtf FilePath
src_fn
is_boot :: IsBootInterface
is_boot = case FilePath -> FilePath
takeExtension FilePath
src_fn of
FilePath
".hs-boot" -> IsBootInterface
IsBoot
FilePath
".lhs-boot" -> IsBootInterface
IsBoot
FilePath
_ -> IsBootInterface
NotBoot
(OsString
path_without_boot, HscSource
hsc_src)
| FilePath -> Bool
isHaskellSigFilename FilePath
src_fn = (OsString
src_path, HscSource
HsigFile)
| IsBootInterface
IsBoot <- IsBootInterface
is_boot = (OsString -> OsString
removeBootSuffix OsString
src_path, HscSource
HsBootFile)
| Bool
otherwise = (OsString
src_path, HscSource
HsSrcFile)
location_without_boot :: ModLocation
location_without_boot =
FinderOpts -> ModuleName -> OsString -> ModLocation
mkHomeModLocation FinderOpts
fopts ModuleName
pi_mod_name OsString
path_without_boot
location :: ModLocation
location
| IsBootInterface
IsBoot <- IsBootInterface
is_boot
= ModLocation -> ModLocation
addBootSuffixLocn ModLocation
location_without_boot
| Bool
otherwise
= ModLocation
location_without_boot
Module
mod <- IO Module -> ExceptT DriverMessages IO Module
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> ExceptT DriverMessages IO Module)
-> IO Module -> ExceptT DriverMessages IO Module
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 -> ModuleNameWithIsBoot -> ModLocation -> IO Module
addHomeModuleToFinder FinderCache
fc HomeUnit
home_unit (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
pi_mod_name IsBootInterface
is_boot) ModLocation
location
IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT DriverMessages IO ModSummary)
-> IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
{ nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
, nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
, 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
}
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 Fingerprint -> Fingerprint -> Bool
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
gwib :: GenWithIsBoot Module
gwib = Module -> IsBootInterface -> GenWithIsBoot Module
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB (ModSummary -> Module
ms_mod ModSummary
old_summary) (ModSummary -> IsBootInterface
isBootSummary ModSummary
old_summary)
case ModSummary -> HscSource
ms_hsc_src ModSummary
old_summary of
HscSource
HsSrcFile -> FinderCache -> GenWithIsBoot Module -> ModLocation -> IO ()
addModuleToFinder FinderCache
fc GenWithIsBoot Module
gwib ModLocation
location
HscSource
_ -> () -> IO ()
forall a. a -> IO a
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 $ ModSummary -> Either e ModSummary
forall a b. b -> Either a b
Right
( ModSummary
old_summary
{ ms_obj_date = obj_timestamp
, ms_iface_date = hi_timestamp
, ms_hie_date = 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 (StringBuffer, 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 (StringBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
| ModuleName
wanted_mod ModuleName -> [ModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
excl_mods
= SummariseResult -> IO SummariseResult
forall a. a -> IO a
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
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
| Maybe FilePath -> Bool
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 <- Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit Module
mod
, Bool -> Bool
not (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod)
-> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SummariseResult -> IO SummariseResult)
-> SummariseResult -> IO SummariseResult
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> SummariseResult
FoundInstantiation InstantiatedUnit
iud
| Bool
otherwise -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SummariseResult -> IO SummariseResult)
-> SummariseResult -> IO SummariseResult
forall a b. (a -> b) -> a -> b
$ UnitId -> SummariseResult
External (Module -> UnitId
moduleUnitId Module
mod)
FindResult
_ -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
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 = FilePath -> Maybe FilePath -> FilePath
forall a. HasDebugCallStack => 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 -> SummariseResult -> IO SummariseResult
forall a. a -> IO a
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 <- (UnitId, FilePath)
-> Map (UnitId, FilePath) ModSummary -> Maybe ModSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ((GenUnit UnitId -> UnitId
toUnitId (Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit Module
mod), FilePath
src_fn)) Map (UnitId, FilePath) ModSummary
old_summary_map =
case Maybe (StringBuffer, UTCTime)
maybe_buf of
Just (StringBuffer
buf,UTCTime
_) ->
HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
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 (StringBuffer -> Fingerprint
fingerprintStringBuffer StringBuffer
buf)
Maybe (StringBuffer, UTCTime)
Nothing ->
HscEnv
-> (Fingerprint -> IO (Either DriverMessages ModSummary))
-> ModSummary
-> ModLocation
-> Fingerprint
-> IO (Either DriverMessages ModSummary)
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
= ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary))
-> ExceptT DriverMessages IO ModSummary
-> IO (Either DriverMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
ModuleName
StringBuffer
SrcSpan
DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> StringBuffer
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_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: Bool
pi_hspp_fn :: FilePath
pi_hspp_buf :: StringBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
..}
<- HscEnv
-> FilePath
-> Maybe Phase
-> Maybe (StringBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports (HasDebugCallStack => UnitId -> HscEnv -> HscEnv
UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (Module -> UnitId
moduleUnitId Module
mod) HscEnv
hsc_env) FilePath
src_fn Maybe Phase
forall a. Maybe a
Nothing Maybe (StringBuffer, UTCTime)
maybe_buf
let hsc_src :: HscSource
hsc_src
| IsBootInterface
is_boot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot = HscSource
HsBootFile
| FilePath -> Bool
isHaskellSigFilename FilePath
src_fn = HscSource
HsigFile
| Bool
otherwise = HscSource
HsSrcFile
Bool
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
pi_mod_name ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) (ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ())
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$
DriverMessages -> ExceptT DriverMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DriverMessages -> ExceptT DriverMessages IO ())
-> DriverMessages -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
(DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleName -> DriverMessage
DriverFileModuleNameMismatch ModuleName
pi_mod_name (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
let instantiations :: GenInstantiations UnitId
instantiations = HomeUnit -> GenInstantiations UnitId
forall u. GenHomeUnit u -> GenInstantiations u
homeUnitInstantiations HomeUnit
home_unit
Bool
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Maybe Module -> Bool
forall a. Maybe a -> Bool
isNothing (ModuleName -> GenInstantiations UnitId -> Maybe Module
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
pi_mod_name GenInstantiations UnitId
instantiations)) (ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ())
-> ExceptT DriverMessages IO () -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$
DriverMessages -> ExceptT DriverMessages IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (DriverMessages -> ExceptT DriverMessages IO ())
-> DriverMessages -> ExceptT DriverMessages IO ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
pi_mod_name_loc
(DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
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
IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT DriverMessages IO ModSummary)
-> IO ModSummary -> ExceptT DriverMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary
{ nms_src_fn :: FilePath
nms_src_fn = FilePath
src_fn
, nms_src_hash :: Fingerprint
nms_src_hash = Fingerprint
src_hash
, 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 -> 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
Module
ModLocation
HscSource
PreprocessedImports
nms_src_fn :: MakeNewModSummary -> FilePath
nms_src_hash :: MakeNewModSummary -> Fingerprint
nms_hsc_src :: MakeNewModSummary -> HscSource
nms_location :: MakeNewModSummary -> ModLocation
nms_mod :: MakeNewModSummary -> Module
nms_preimps :: MakeNewModSummary -> PreprocessedImports
nms_src_fn :: FilePath
nms_src_hash :: Fingerprint
nms_hsc_src :: HscSource
nms_location :: ModLocation
nms_mod :: Module
nms_preimps :: PreprocessedImports
..} = do
let PreprocessedImports{Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
ModuleName
StringBuffer
SrcSpan
DynFlags
pi_mod_name :: PreprocessedImports -> ModuleName
pi_mod_name_loc :: PreprocessedImports -> SrcSpan
pi_hspp_buf :: PreprocessedImports -> StringBuffer
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_local_dflags :: DynFlags
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_ghc_prim_import :: Bool
pi_hspp_fn :: FilePath
pi_hspp_buf :: StringBuffer
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
..} = 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
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 StringBuffer
ms_hspp_buf = StringBuffer -> Maybe StringBuffer
forall a. a -> Maybe a
Just StringBuffer
pi_hspp_buf
, ms_parsed_mod :: Maybe HsParsedModule
ms_parsed_mod = Maybe HsParsedModule
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 (GenLocated SrcSpan ModuleName
-> (PkgQual, GenLocated SrcSpan ModuleName))
-> (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName
-> (PkgQual, GenLocated SrcSpan ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (PkgQual, GenLocated SrcSpan ModuleName))
-> [ModuleName] -> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
extra_sig_imports) [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall a. [a] -> [a] -> [a]
++
((,) PkgQual
NoPkgQual (GenLocated SrcSpan ModuleName
-> (PkgQual, GenLocated SrcSpan ModuleName))
-> (ModuleName -> GenLocated SrcSpan ModuleName)
-> ModuleName
-> (PkgQual, GenLocated SrcSpan ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> GenLocated SrcSpan ModuleName
forall e. e -> Located e
noLoc (ModuleName -> (PkgQual, GenLocated SrcSpan ModuleName))
-> [ModuleName] -> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ModuleName]
implicit_sigs) [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
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 -> StringBuffer
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 (StringBuffer, UTCTime)
-> ExceptT DriverMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env FilePath
src_fn Maybe Phase
mb_phase Maybe (StringBuffer, UTCTime)
maybe_buf = do
(DynFlags
pi_local_dflags, FilePath
pi_hspp_fn)
<- IO (Either DriverMessages (DynFlags, FilePath))
-> ExceptT DriverMessages IO (DynFlags, FilePath)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DriverMessages (DynFlags, FilePath))
-> ExceptT DriverMessages IO (DynFlags, FilePath))
-> IO (Either DriverMessages (DynFlags, FilePath))
-> ExceptT DriverMessages IO (DynFlags, FilePath)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> Maybe StringBuffer
-> Maybe Phase
-> IO (Either DriverMessages (DynFlags, FilePath))
preprocess HscEnv
hsc_env FilePath
src_fn ((StringBuffer, UTCTime) -> StringBuffer
forall a b. (a, b) -> a
fst ((StringBuffer, UTCTime) -> StringBuffer)
-> Maybe (StringBuffer, UTCTime) -> Maybe StringBuffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (StringBuffer, UTCTime)
maybe_buf) Maybe Phase
mb_phase
StringBuffer
pi_hspp_buf <- IO StringBuffer -> ExceptT DriverMessages IO StringBuffer
forall a. IO a -> ExceptT DriverMessages IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> ExceptT DriverMessages IO StringBuffer)
-> IO StringBuffer -> ExceptT DriverMessages IO StringBuffer
forall a b. (a -> b) -> a -> b
$ FilePath -> IO StringBuffer
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)
<- IO
(Either
DriverMessages
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
-> ExceptT
DriverMessages
IO
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO
(Either
DriverMessages
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
-> ExceptT
DriverMessages
IO
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
-> IO
(Either
DriverMessages
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
-> ExceptT
DriverMessages
IO
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
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
-> StringBuffer
-> FilePath
-> FilePath
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName))
getImports ParserOpts
popts Bool
imp_prelude StringBuffer
pi_hspp_buf FilePath
pi_hspp_fn FilePath
src_fn
return ((Messages PsMessage -> DriverMessages)
-> Either
(Messages PsMessage)
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
-> Either
DriverMessages
([(RawPkgQual, GenLocated SrcSpan ModuleName)],
[(RawPkgQual, GenLocated SrcSpan ModuleName)], Bool,
GenLocated SrcSpan ModuleName)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Bag (MsgEnvelope DriverMessage) -> DriverMessages
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope DriverMessage) -> DriverMessages)
-> (Messages PsMessage -> Bag (MsgEnvelope DriverMessage))
-> Messages PsMessage
-> DriverMessages
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MsgEnvelope PsMessage -> MsgEnvelope DriverMessage)
-> Bag (MsgEnvelope PsMessage) -> Bag (MsgEnvelope DriverMessage)
forall a b. (a -> b) -> Bag a -> Bag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage (Bag (MsgEnvelope PsMessage) -> Bag (MsgEnvelope DriverMessage))
-> (Messages PsMessage -> Bag (MsgEnvelope PsMessage))
-> Messages PsMessage
-> Bag (MsgEnvelope DriverMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages PsMessage -> Bag (MsgEnvelope PsMessage)
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 = ((RawPkgQual, GenLocated SrcSpan ModuleName)
-> (PkgQual, GenLocated SrcSpan ModuleName))
-> [(RawPkgQual, GenLocated SrcSpan ModuleName)]
-> [(PkgQual, GenLocated SrcSpan ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
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'
PreprocessedImports
-> ExceptT DriverMessages IO PreprocessedImports
forall a. a -> ExceptT DriverMessages IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return PreprocessedImports {Bool
FilePath
[(PkgQual, GenLocated SrcSpan ModuleName)]
ModuleName
StringBuffer
SrcSpan
DynFlags
pi_mod_name :: ModuleName
pi_mod_name_loc :: SrcSpan
pi_hspp_buf :: StringBuffer
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_local_dflags :: DynFlags
pi_hspp_fn :: FilePath
pi_hspp_buf :: StringBuffer
pi_ghc_prim_import :: Bool
pi_mod_name_loc :: SrcSpan
pi_mod_name :: ModuleName
pi_srcimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
pi_theimps :: [(PkgQual, GenLocated SrcSpan ModuleName)]
..}
withDeferredDiagnostics :: GhcMonad m => m a -> m a
withDeferredDiagnostics :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withDeferredDiagnostics m a
f = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DeferDiagnostics DynFlags
dflags
then m a
f
else do
IORef [IO ()]
warnings <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
IORef [IO ()]
errors <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
IORef [IO ()]
fatals <- IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [IO ()]) -> m (IORef [IO ()]))
-> IO (IORef [IO ()]) -> m (IORef [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
Logger
logger <- m 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 ResolvedDiagnosticReason
_reason Maybe DiagnosticCode
_code
-> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
warnings (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(![IO ()]
i) -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
MCDiagnostic Severity
SevError ResolvedDiagnosticReason
_reason Maybe DiagnosticCode
_code
-> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
errors (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(![IO ()]
i) -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
MessageClass
MCFatal
-> IORef [IO ()] -> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [IO ()]
fatals (([IO ()] -> ([IO ()], ())) -> IO ())
-> ([IO ()] -> ([IO ()], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(![IO ()]
i) -> (IO ()
actionIO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
i, ())
MessageClass
_ -> IO ()
action
printDeferredDiagnostics :: m ()
printDeferredDiagnostics = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
[IORef [IO ()]] -> (IORef [IO ()] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [IORef [IO ()]
warnings, IORef [IO ()]
errors, IORef [IO ()]
fatals] ((IORef [IO ()] -> IO ()) -> IO ())
-> (IORef [IO ()] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IORef [IO ()]
ref -> do
let landmine :: [a]
landmine = if Bool
debugIsOn then FilePath -> [a]
forall a. HasCallStack => FilePath -> a
panic FilePath
"withDeferredDiagnostics: use after free" else []
[IO ()]
actions <- IORef [IO ()] -> ([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [IO ()]
ref (([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()])
-> ([IO ()] -> ([IO ()], [IO ()])) -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ \[IO ()]
i -> ([IO ()]
forall a. [a]
landmine, [IO ()]
i)
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> [IO ()]
forall a. [a] -> [a]
reverse [IO ()]
actions
m () -> (() -> m ()) -> (() -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket
(((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
forall (m :: * -> *).
GhcMonad m =>
((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> m ()
pushLogHookM ((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> (LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags
-> MessageClass
-> SrcSpan
-> SDoc
-> IO ()
forall a b. a -> b -> a
const LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ()
deferDiagnostics))
(\()
_ -> m ()
forall (m :: * -> *). GhcMonad m => m ()
popLogHookM m () -> m () -> m ()
forall a b. m a -> m b -> m b
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
= SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$
IfaceMessage -> DriverMessage
DriverInterfaceError (IfaceMessage -> DriverMessage) -> IfaceMessage -> DriverMessage
forall a b. (a -> b) -> a -> b
$
(MissingInterfaceError -> InterfaceLookingFor -> IfaceMessage
Can'tFindInterface (HscEnv -> ModuleName -> FindResult -> MissingInterfaceError
cannotFindModule HscEnv
hsc_env ModuleName
wanted_mod FindResult
err) (ModuleName -> IsBootInterface -> InterfaceLookingFor
LookingForModule ModuleName
wanted_mod IsBootInterface
NotBoot))
moduleNotFoundErr :: ModuleName -> DriverMessages
moduleNotFoundErr :: ModuleName -> DriverMessages
moduleNotFoundErr ModuleName
mod = MsgEnvelope DriverMessage -> DriverMessages
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope DriverMessage -> DriverMessages)
-> MsgEnvelope DriverMessage -> DriverMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (ModuleName -> DriverMessage
DriverModuleNotFound ModuleName
mod)
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
panic FilePath
"multiRootsErr"
multiRootsErr summs :: [ModSummary]
summs@(ModSummary
summ1:[ModSummary]
_)
= MsgEnvelope GhcMessage -> IO ()
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO ())
-> MsgEnvelope GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ (DriverMessage -> GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage (MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage)
-> MsgEnvelope DriverMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
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 = (ModSummary -> FilePath) -> [ModSummary] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe FilePath -> FilePath
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"checkDup" (Maybe FilePath -> FilePath)
-> (ModSummary -> Maybe FilePath) -> ModSummary -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModLocation -> Maybe FilePath
ml_hs_file (ModLocation -> Maybe FilePath)
-> (ModSummary -> ModLocation) -> ModSummary -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location) [ModSummary]
summs
cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage
cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage
cyclicModuleErr [ModuleGraphNode]
mss
= Bool -> MsgEnvelope GhcMessage -> MsgEnvelope GhcMessage
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([ModuleGraphNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleGraphNode]
mss)) (MsgEnvelope GhcMessage -> MsgEnvelope GhcMessage)
-> MsgEnvelope GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
case [Node NodeKey ModuleGraphNode] -> Maybe [ModuleGraphNode]
forall payload key.
Ord key =>
[Node key payload] -> Maybe [payload]
findCycle [Node NodeKey ModuleGraphNode]
graph of
Maybe [ModuleGraphNode]
Nothing -> FilePath -> SDoc -> MsgEnvelope GhcMessage
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"Unexpected non-cycle" ([ModuleGraphNode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleGraphNode]
mss)
Just [ModuleGraphNode]
path -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
src_span (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ [ModuleGraphNode] -> DriverMessage
DriverModuleGraphCycle [ModuleGraphNode]
path
where
src_span :: SrcSpan
src_span = SrcSpan -> (ModSummary -> SrcSpan) -> Maybe ModSummary -> SrcSpan
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SrcSpan
noSrcSpan (ModLocation -> SrcSpan
mkFileSrcSpan (ModLocation -> SrcSpan)
-> (ModSummary -> ModLocation) -> ModSummary -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> ModLocation
ms_location) (ModuleGraphNode -> Maybe ModSummary
moduleGraphNodeModSum ([ModuleGraphNode] -> ModuleGraphNode
forall a. HasCallStack => [a] -> a
head [ModuleGraphNode]
path))
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
]
cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe :: forall (m :: * -> *).
MonadIO m =>
Logger -> TmpFs -> DynFlags -> m ()
cleanCurrentModuleTempFilesMaybe Logger
logger TmpFs
tmpfs DynFlags
dflags =
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_KeepTmpFiles DynFlags
dflags
then IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Logger -> TmpFs -> IO ()
Logger -> TmpFs -> IO ()
keepCurrentModuleTempFiles Logger
logger TmpFs
tmpfs
else IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 =
(UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG (\UnitEnvGraph HomeUnitEnv
hug -> (HomeModInfo
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> [HomeModInfo]
-> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeModInfo -> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
addHomeModInfoToHug UnitEnvGraph HomeUnitEnv
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 (HomePackageTable -> HomePackageTable -> HomePackageTable
forall a b. a -> b -> a
const (HomePackageTable -> HomePackageTable -> HomePackageTable)
-> HomePackageTable -> HomePackageTable -> HomePackageTable
forall a b. (a -> b) -> a -> b
$ HomePackageTable
deps) HscEnv
hsc_env
setHUG :: HomeUnitGraph -> HscEnv -> HscEnv
setHUG :: UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
deps HscEnv
hsc_env =
(UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> HscEnv -> HscEnv
hscUpdateHUG (UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall a b. a -> b -> a
const (UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv
-> UnitEnvGraph HomeUnitEnv
forall a b. (a -> b) -> a -> b
$ UnitEnvGraph HomeUnitEnv
deps) HscEnv
hsc_env
wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction :: forall a.
(GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction GhcMessage -> AnyGhcDiagnostic
msg_wrapper 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
logg :: SourceError -> IO ()
logg SourceError
err = Logger
-> DiagnosticOpts (UnknownDiagnostic GhcMessageOpts)
-> DiagOpts
-> Messages (UnknownDiagnostic GhcMessageOpts)
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
lcl_logger DiagnosticOpts (UnknownDiagnostic GhcMessageOpts)
DiagnosticOpts GhcMessage
print_config (DynFlags -> DiagOpts
initDiagOpts DynFlags
lcl_dynflags) (GhcMessage -> AnyGhcDiagnostic
GhcMessage -> UnknownDiagnostic GhcMessageOpts
msg_wrapper (GhcMessage -> UnknownDiagnostic GhcMessageOpts)
-> Messages GhcMessage
-> Messages (UnknownDiagnostic GhcMessageOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceError -> Messages GhcMessage
srcErrorMessages SourceError
err)
Either SomeException a
mres <- IO a -> IO (Either SomeException a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ Logger -> IO a -> IO a
forall (m :: * -> *) a. ExceptionMonad m => Logger -> m a -> m a
prettyPrintGhcErrors Logger
lcl_logger (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a
k
case Either SomeException a
mres of
Right a
res -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
res
Left SomeException
exc -> do
case SomeException -> Maybe SourceError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just (SourceError
err :: SourceError)
-> SourceError -> IO ()
logg SourceError
err
Maybe SourceError
Nothing -> case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc of
Just (SomeAsyncException
err :: SomeAsyncException) -> SomeAsyncException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeAsyncException
err
Maybe SomeAsyncException
_ -> Logger -> SDoc -> IO ()
errorMsg Logger
lcl_logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
exc))
return Maybe a
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
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
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 = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LogQueue -> IO ()
finishLogQueue LogQueue
lq)
IO LogQueue -> (LogQueue -> IO ()) -> (LogQueue -> IO b) -> IO b
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO LogQueue
init_log LogQueue -> IO ()
forall {m :: * -> *}. MonadIO m => LogQueue -> m ()
finish_log ((LogQueue -> IO b) -> IO b) -> (LogQueue -> IO b) -> IO b
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 ((LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> (LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO ())
-> LogFlags
-> MessageClass
-> SrcSpan
-> SDoc
-> IO ()
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 :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger, HscEnv
hsc_env :: MakeEnv -> HscEnv
hsc_env :: HscEnv
hsc_env} HscEnv -> IO a
cont = do
Int -> ((Logger -> Logger) -> IO a) -> IO a
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
withLogger Int
k (((Logger -> Logger) -> IO a) -> IO a)
-> ((Logger -> Logger) -> IO a) -> IO a
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 = lcl_logger }
HscEnv -> IO a
cont HscEnv
hsc_env'
executeInstantiationNode :: Int
-> Int
-> HomeUnitGraph
-> UnitId
-> InstantiatedUnit
-> RunMakeM ()
executeInstantiationNode :: Int
-> Int
-> UnitEnvGraph HomeUnitEnv
-> UnitId
-> InstantiatedUnit
-> ReaderT MakeEnv (MaybeT IO) ()
executeInstantiationNode Int
k Int
n UnitEnvGraph HomeUnitEnv
deps UnitId
uid InstantiatedUnit
iu = do
MakeEnv
env <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
Maybe Messager
msg <- (MakeEnv -> Maybe Messager)
-> ReaderT MakeEnv (MaybeT IO) (Maybe Messager)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> Maybe Messager
env_messager
GhcMessage -> UnknownDiagnostic GhcMessageOpts
wrapper <- (MakeEnv -> GhcMessage -> UnknownDiagnostic GhcMessageOpts)
-> ReaderT
MakeEnv
(MaybeT IO)
(GhcMessage -> UnknownDiagnostic GhcMessageOpts)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks MakeEnv -> GhcMessage -> AnyGhcDiagnostic
MakeEnv -> GhcMessage -> UnknownDiagnostic GhcMessageOpts
diag_wrapper
MaybeT IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO () -> ReaderT MakeEnv (MaybeT IO) ())
-> MaybeT IO () -> ReaderT MakeEnv (MaybeT IO) ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe ()) -> MaybeT IO ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe ()) -> MaybeT IO ()) -> IO (Maybe ()) -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> MakeEnv -> (HscEnv -> IO (Maybe ())) -> IO (Maybe ())
forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
env ((HscEnv -> IO (Maybe ())) -> IO (Maybe ()))
-> (HscEnv -> IO (Maybe ())) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
let lcl_hsc_env :: HscEnv
lcl_hsc_env = UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
deps HscEnv
hsc_env
in (GhcMessage -> AnyGhcDiagnostic)
-> HscEnv -> IO () -> IO (Maybe ())
forall a.
(GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction GhcMessage -> AnyGhcDiagnostic
GhcMessage -> UnknownDiagnostic GhcMessageOpts
wrapper HscEnv
lcl_hsc_env (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
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
Logger -> TmpFs -> DynFlags -> IO ()
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
-> UnitEnvGraph HomeUnitEnv
-> Maybe [ModuleName]
-> ModSummary
-> ReaderT MakeEnv (MaybeT IO) HomeModInfo
executeCompileNode Int
k Int
n !Maybe HomeModInfo
old_hmi UnitEnvGraph HomeUnitEnv
hug Maybe [ModuleName]
mrehydrate_mods ModSummary
mod = do
me :: MakeEnv
me@MakeEnv{Maybe Messager
AbstractSem
HscEnv
GhcMessage -> AnyGhcDiagnostic
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
hsc_env :: MakeEnv -> HscEnv
compile_sem :: MakeEnv -> AbstractSem
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: MakeEnv -> Maybe Messager
diag_wrapper :: MakeEnv -> GhcMessage -> AnyGhcDiagnostic
hsc_env :: HscEnv
compile_sem :: AbstractSem
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
..} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
MaybeT IO HomeModInfo -> ReaderT MakeEnv (MaybeT IO) HomeModInfo
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO HomeModInfo -> ReaderT MakeEnv (MaybeT IO) HomeModInfo)
-> MaybeT IO HomeModInfo -> ReaderT MakeEnv (MaybeT IO) HomeModInfo
forall a b. (a -> b) -> a -> b
$ IO (Maybe HomeModInfo) -> MaybeT IO HomeModInfo
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (AbstractSem -> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ Int
-> MakeEnv
-> (HscEnv -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo)
forall a. Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
withLoggerHsc Int
k MakeEnv
me ((HscEnv -> IO (Maybe HomeModInfo)) -> IO (Maybe HomeModInfo))
-> (HscEnv -> IO (Maybe HomeModInfo)) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env -> do
HscEnv
hydrated_hsc_env <- IO HscEnv -> IO HscEnv
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> IO HscEnv) -> IO HscEnv -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
maybeRehydrateBefore (UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
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
DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
lcl_dynflags (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$
HscEnv
hydrated_hsc_env
(GhcMessage -> AnyGhcDiagnostic)
-> HscEnv -> IO HomeModInfo -> IO (Maybe HomeModInfo)
forall a.
(GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)
wrapAction GhcMessage -> AnyGhcDiagnostic
diag_wrapper HscEnv
lcl_hsc_env (IO HomeModInfo -> IO (Maybe HomeModInfo))
-> IO HomeModInfo -> IO (Maybe HomeModInfo)
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
Logger -> TmpFs -> DynFlags -> IO ()
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 -> [ModuleName] -> Maybe [ModuleName]
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 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ (
FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Re-hydrating loop: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((HomeModInfo -> Module) -> [HomeModInfo] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis)))
[(ModuleName, HomeModInfo)]
new_mods <- ([(ModuleName, HomeModInfo)] -> IO [(ModuleName, HomeModInfo)])
-> IO [(ModuleName, HomeModInfo)]
forall a. (a -> IO a) -> IO a
fixIO (([(ModuleName, HomeModInfo)] -> IO [(ModuleName, HomeModInfo)])
-> IO [(ModuleName, HomeModInfo)])
-> ([(ModuleName, HomeModInfo)] -> IO [(ModuleName, HomeModInfo)])
-> IO [(ModuleName, HomeModInfo)]
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 (HomePackageTable -> HomePackageTable -> HomePackageTable
forall a b. a -> b -> a
const HomePackageTable
new_hpt) HscEnv
hsc_env
[ModDetails]
mds <- SDoc -> HscEnv -> IfG [ModDetails] -> IO [ModDetails]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"rehydrate") HscEnv
new_hsc_env (IfG [ModDetails] -> IO [ModDetails])
-> IfG [ModDetails] -> IO [ModDetails]
forall a b. (a -> b) -> a -> b
$
(HomeModInfo -> IOEnv (Env IfGblEnv ()) ModDetails)
-> [HomeModInfo] -> IfG [ModDetails]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails
typecheckIface (ModIface -> IOEnv (Env IfGblEnv ()) ModDetails)
-> (HomeModInfo -> ModIface)
-> HomeModInfo
-> IOEnv (Env IfGblEnv ()) ModDetails
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 = details })
| (HomeModInfo
hmi,ModDetails
details) <- [HomeModInfo] -> [ModDetails] -> [(HomeModInfo, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds
, let mn :: ModuleName
mn = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi)) ]
[(ModuleName, HomeModInfo)] -> IO [(ModuleName, HomeModInfo)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return [(ModuleName, HomeModInfo)]
new_mods
return $ HomePackageTable -> HscEnv -> HscEnv
setHPT ((HomePackageTable -> (ModuleName, HomeModInfo) -> HomePackageTable)
-> HomePackageTable
-> [(ModuleName, HomeModInfo)]
-> HomePackageTable
forall b a. (b -> a -> b) -> b -> [a] -> b
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 = ((HomeModInfo -> ModuleName) -> [HomeModInfo] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName)
-> (HomeModInfo -> Module) -> HomeModInfo -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface) [HomeModInfo]
hmis)
!old_hpt :: HomePackageTable
old_hpt = (HomePackageTable -> ModuleName -> HomePackageTable)
-> HomePackageTable -> [ModuleName] -> HomePackageTable
forall b a. (b -> a -> b) -> b -> [a] -> b
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 = HscEnv -> IO HscEnv
forall a. a -> IO a
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 = (ModuleName -> HomeModInfo) -> [ModuleName] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"mr" (Maybe HomeModInfo -> HomeModInfo)
-> (ModuleName -> Maybe HomeModInfo) -> ModuleName -> HomeModInfo
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 = knotVarsFromModuleEnv knot_var }) [HomeModInfo]
hmis
where
initialise_knot_var :: HscEnv -> IO (ModuleEnv (IORef TypeEnv))
initialise_knot_var HscEnv
hsc_env = IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv)))
-> IO (ModuleEnv (IORef TypeEnv)) -> IO (ModuleEnv (IORef TypeEnv))
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 [(Module, IORef TypeEnv)] -> ModuleEnv (IORef TypeEnv)
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv ([(Module, IORef TypeEnv)] -> ModuleEnv (IORef TypeEnv))
-> (IORef TypeEnv -> [(Module, IORef TypeEnv)])
-> IORef TypeEnv
-> ModuleEnv (IORef TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Module, IORef TypeEnv)
-> [(Module, IORef TypeEnv)] -> [(Module, IORef TypeEnv)]
forall a. a -> [a] -> [a]
:[]) ((Module, IORef TypeEnv) -> [(Module, IORef TypeEnv)])
-> (IORef TypeEnv -> (Module, IORef TypeEnv))
-> IORef TypeEnv
-> [(Module, IORef TypeEnv)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module
mod_name,) (IORef TypeEnv -> ModuleEnv (IORef TypeEnv))
-> IO (IORef TypeEnv) -> IO (ModuleEnv (IORef TypeEnv))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeEnv -> IO (IORef TypeEnv)
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 = (ModuleName -> HomeModInfo) -> [ModuleName] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"mrAfter" (Maybe HomeModInfo -> HomeModInfo)
-> (ModuleName -> Maybe HomeModInfo) -> ModuleName -> HomeModInfo
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 = emptyKnotVars }) [HomeModInfo]
hmis
return $ (ModuleName -> HomeModInfo) -> [ModuleName] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
mn -> FilePath -> Maybe HomeModInfo -> HomeModInfo
forall a. HasDebugCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"rehydrate" (Maybe HomeModInfo -> HomeModInfo)
-> Maybe HomeModInfo -> HomeModInfo
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 :: UnitEnvGraph HomeUnitEnv
-> (Int, Int)
-> UnitId
-> [NodeKey]
-> ReaderT MakeEnv (MaybeT IO) ()
executeLinkNode UnitEnvGraph HomeUnitEnv
hug (Int, Int)
kn UnitId
uid [NodeKey]
deps = do
UnitId
-> ReaderT MakeEnv (MaybeT IO) () -> ReaderT MakeEnv (MaybeT IO) ()
forall a. UnitId -> RunMakeM a -> RunMakeM a
withCurrentUnit UnitId
uid (ReaderT MakeEnv (MaybeT IO) () -> ReaderT MakeEnv (MaybeT IO) ())
-> ReaderT MakeEnv (MaybeT IO) () -> ReaderT MakeEnv (MaybeT IO) ()
forall a b. (a -> b) -> a -> b
$ do
MakeEnv{Maybe Messager
AbstractSem
HscEnv
GhcMessage -> AnyGhcDiagnostic
forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
hsc_env :: MakeEnv -> HscEnv
compile_sem :: MakeEnv -> AbstractSem
withLogger :: MakeEnv -> forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: MakeEnv -> Maybe Messager
diag_wrapper :: MakeEnv -> GhcMessage -> AnyGhcDiagnostic
hsc_env :: HscEnv
compile_sem :: AbstractSem
withLogger :: forall a. Int -> ((Logger -> Logger) -> IO a) -> IO a
env_messager :: Maybe Messager
diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
..} <- ReaderT MakeEnv (MaybeT IO) MakeEnv
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' = UnitEnvGraph HomeUnitEnv -> HscEnv -> HscEnv
setHUG UnitEnvGraph HomeUnitEnv
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)) (Messager -> RecompileRequired -> IO ())
-> Maybe Messager -> Maybe (RecompileRequired -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Messager
env_messager
SuccessFlag
linkresult <- IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag)
-> IO SuccessFlag -> ReaderT MakeEnv (MaybeT IO) SuccessFlag
forall a b. (a -> b) -> a -> b
$ AbstractSem -> IO SuccessFlag -> IO SuccessFlag
forall b. AbstractSem -> IO b -> IO b
withAbstractSem AbstractSem
compile_sem (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
GhcLink
-> Logger
-> TmpFs
-> FinderCache
-> 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 -> FinderCache
hsc_FC 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 -> FilePath -> ReaderT MakeEnv (MaybeT IO) ()
forall a. FilePath -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Link Failed"
SuccessFlag
Succeeded -> () -> ReaderT MakeEnv (MaybeT IO) ()
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
type ModuleNameSet = M.Map UnitId W.Word64Set
addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
addToModuleNameSet UnitId
uid ModuleName
mn ModuleNameSet
s =
let k :: Word64
k = (Unique -> Word64
getKey (Unique -> Word64) -> Unique -> Word64
forall a b. (a -> b) -> a -> b
$ ModuleName -> Unique
forall a. Uniquable a => a -> Unique
getUnique (ModuleName -> Unique) -> ModuleName -> Unique
forall a b. (a -> b) -> a -> b
$ ModuleName
mn)
in (Word64Set -> Word64Set -> Word64Set)
-> UnitId -> Word64Set -> ModuleNameSet -> ModuleNameSet
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Word64Set -> Word64Set -> Word64Set
W.union) UnitId
uid (Word64 -> Word64Set
W.singleton Word64
k) ModuleNameSet
s
wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
wait_deps_hug :: MVar (UnitEnvGraph HomeUnitEnv)
-> [BuildResult]
-> ReaderT
MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv, ModuleNameSet)
wait_deps_hug MVar (UnitEnvGraph HomeUnitEnv)
hug_var [BuildResult]
deps = do
([HomeModInfo]
_, ModuleNameSet
module_deps) <- [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps [BuildResult]
deps
UnitEnvGraph HomeUnitEnv
hug <- IO (UnitEnvGraph HomeUnitEnv)
-> ReaderT MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv)
forall a. IO a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UnitEnvGraph HomeUnitEnv)
-> ReaderT MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv))
-> IO (UnitEnvGraph HomeUnitEnv)
-> ReaderT MakeEnv (MaybeT IO) (UnitEnvGraph HomeUnitEnv)
forall a b. (a -> b) -> a -> b
$ MVar (UnitEnvGraph HomeUnitEnv) -> IO (UnitEnvGraph HomeUnitEnv)
forall a. MVar a -> IO a
readMVar MVar (UnitEnvGraph HomeUnitEnv)
hug_var
let pruneHomeUnitEnv :: UnitId -> HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv UnitId
uid HomeUnitEnv
hme =
let
!new :: HomePackageTable
new = HomePackageTable -> Word64Set -> HomePackageTable
forall {k} (key :: k) elt.
UniqDFM key elt -> Word64Set -> UniqDFM key elt
udfmRestrictKeysSet (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hme) (Word64Set -> Maybe Word64Set -> Word64Set
forall a. a -> Maybe a -> a
fromMaybe Word64Set
W.empty (Maybe Word64Set -> Word64Set) -> Maybe Word64Set -> Word64Set
forall a b. (a -> b) -> a -> b
$ UnitId -> ModuleNameSet -> Maybe Word64Set
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UnitId
uid ModuleNameSet
module_deps)
in HomeUnitEnv
hme { homeUnitEnv_hpt = new }
return ((UnitId -> HomeUnitEnv -> HomeUnitEnv)
-> UnitEnvGraph HomeUnitEnv -> UnitEnvGraph HomeUnitEnv
forall v b. (UnitId -> v -> b) -> UnitEnvGraph v -> UnitEnvGraph b
unitEnv_mapWithKey UnitId -> HomeUnitEnv -> HomeUnitEnv
pruneHomeUnitEnv UnitEnvGraph HomeUnitEnv
hug, ModuleNameSet
module_deps)
wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
wait_deps [] = ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ModuleNameSet
forall k a. Map k a
M.empty)
wait_deps (BuildResult
x:[BuildResult]
xs) = do
(Maybe HomeModInfo
res, ModuleNameSet
deps) <- MaybeT IO (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall (m :: * -> *) a. Monad m => m a -> ReaderT MakeEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MaybeT IO (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet))
-> MaybeT IO (Maybe HomeModInfo, ModuleNameSet)
-> RunMakeM (Maybe HomeModInfo, ModuleNameSet)
forall a b. (a -> b) -> a -> b
$ ResultVar (Maybe HomeModInfo, ModuleNameSet)
-> MaybeT IO (Maybe HomeModInfo, ModuleNameSet)
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 -> ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([HomeModInfo]
hmis, ModuleNameSet
new_deps)
Just HomeModInfo
hmi -> ([HomeModInfo], ModuleNameSet)
-> RunMakeM ([HomeModInfo], ModuleNameSet)
forall a. a -> ReaderT MakeEnv (MaybeT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo
hmiHomeModInfo -> [HomeModInfo] -> [HomeModInfo]
forall a. a -> [a] -> [a]
:[HomeModInfo]
hmis, ModuleNameSet
new_deps)
where
unionModuleNameSet :: ModuleNameSet -> ModuleNameSet -> ModuleNameSet
unionModuleNameSet = (Word64Set -> Word64Set -> Word64Set)
-> ModuleNameSet -> ModuleNameSet -> ModuleNameSet
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Word64Set -> Word64Set -> Word64Set
W.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 :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()
runPipelines :: WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runPipelines WorkerLimit
n_job HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessager [MakeAction]
all_pipelines = do
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
label_self FilePath
"main --make thread"
case WorkerLimit
n_job of
NumProcessorsLimit Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 -> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runSeqPipelines HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessager [MakeAction]
all_pipelines
WorkerLimit
_n -> WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runParPipelines WorkerLimit
n_job HscEnv
hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessager [MakeAction]
all_pipelines
runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()
runSeqPipelines :: HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runSeqPipelines HscEnv
plugin_hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper 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 Logger -> Logger
forall a. a -> a
id
, compile_sem :: AbstractSem
compile_sem = IO () -> IO () -> AbstractSem
AbstractSem (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, env_messager :: Maybe Messager
env_messager = Maybe Messager
mHscMessager
, diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
diag_wrapper = GhcMessage -> AnyGhcDiagnostic
diag_wrapper
}
in WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines (Int -> WorkerLimit
NumProcessorsLimit Int
1) MakeEnv
env [MakeAction]
all_pipelines
runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a
runNjobsAbstractSem :: forall a. Int -> (AbstractSem -> IO a) -> IO a
runNjobsAbstractSem Int
n_jobs AbstractSem -> IO a
action = do
QSem
compile_sem <- Int -> IO QSem
newQSem Int
n_jobs
Int
n_capabilities <- IO Int
getNumCapabilities
Int
n_cpus <- IO Int
getNumProcessors
let
asem :: AbstractSem
asem = IO () -> IO () -> AbstractSem
AbstractSem (QSem -> IO ()
waitQSem QSem
compile_sem) (QSem -> IO ()
signalQSem QSem
compile_sem)
set_num_caps :: Int -> IO ()
set_num_caps Int
n = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n_capabilities Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n
updNumCapabilities :: IO ()
updNumCapabilities = do
Int -> IO ()
set_num_caps (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n_jobs Int
n_cpus
resetNumCapabilities :: IO ()
resetNumCapabilities = Int -> IO ()
set_num_caps Int
n_capabilities
IO () -> IO () -> IO a -> IO a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
MC.bracket_ IO ()
updNumCapabilities IO ()
resetNumCapabilities (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ AbstractSem -> IO a
action AbstractSem
asem
runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a
#if defined(wasm32_HOST_ARCH)
runWorkerLimit _ action = do
lock <- newMVar ()
action $ AbstractSem (takeMVar lock) (putMVar lock ())
#else
runWorkerLimit :: forall a. WorkerLimit -> (AbstractSem -> IO a) -> IO a
runWorkerLimit WorkerLimit
worker_limit AbstractSem -> IO a
action = case WorkerLimit
worker_limit of
NumProcessorsLimit Int
n_jobs ->
Int -> (AbstractSem -> IO a) -> IO a
forall a. Int -> (AbstractSem -> IO a) -> IO a
runNjobsAbstractSem Int
n_jobs AbstractSem -> IO a
action
JSemLimit SemaphoreName
sem ->
SemaphoreName -> (AbstractSem -> IO a) -> IO a
forall a. SemaphoreName -> (AbstractSem -> IO a) -> IO a
runJSemAbstractSem SemaphoreName
sem AbstractSem -> IO a
action
#endif
runParPipelines :: WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runParPipelines :: WorkerLimit
-> HscEnv
-> (GhcMessage -> AnyGhcDiagnostic)
-> Maybe Messager
-> [MakeAction]
-> IO ()
runParPipelines WorkerLimit
worker_limit HscEnv
plugin_hsc_env GhcMessage -> AnyGhcDiagnostic
diag_wrapper Maybe Messager
mHscMessager [MakeAction]
all_pipelines = do
TVar Bool
stopped_var <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
TVar LogQueueQueue
log_queue_queue_var <- LogQueueQueue -> IO (TVar LogQueueQueue)
forall a. a -> IO (TVar a)
newTVarIO LogQueueQueue
newLogQueueQueue
IO ()
wait_log_thread <- Logger -> TVar Bool -> TVar LogQueueQueue -> IO (IO ())
logThread (HscEnv -> Logger
hsc_logger HscEnv
plugin_hsc_env) TVar Bool
stopped_var TVar LogQueueQueue
log_queue_queue_var
Logger
thread_safe_logger <- IO Logger -> IO Logger
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Logger -> IO Logger) -> IO Logger -> IO Logger
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 = thread_safe_logger }
WorkerLimit -> (AbstractSem -> IO ()) -> IO ()
forall a. WorkerLimit -> (AbstractSem -> IO a) -> IO a
runWorkerLimit WorkerLimit
worker_limit ((AbstractSem -> IO ()) -> IO ())
-> (AbstractSem -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AbstractSem
abstract_sem -> do
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 = TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO a) -> IO a
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
, diag_wrapper :: GhcMessage -> AnyGhcDiagnostic
diag_wrapper = GhcMessage -> AnyGhcDiagnostic
diag_wrapper
}
WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines WorkerLimit
worker_limit MakeEnv
env [MakeAction]
all_pipelines
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
stopped_var Bool
True
IO ()
wait_log_thread
withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a
withLocalTmpFS :: forall a. TmpFs -> (TmpFs -> IO a) -> IO a
withLocalTmpFS TmpFs
tmpfs TmpFs -> IO a
act = do
let initialiser :: IO TmpFs
initialiser = do
IO TmpFs -> IO TmpFs
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TmpFs -> IO TmpFs) -> IO TmpFs -> IO TmpFs
forall a b. (a -> b) -> a -> b
$ TmpFs -> IO TmpFs
forkTmpFsFrom TmpFs
tmpfs
finaliser :: TmpFs -> IO ()
finaliser TmpFs
tmpfs_local = do
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TmpFs -> TmpFs -> IO ()
mergeTmpFsInto TmpFs
tmpfs_local TmpFs
tmpfs
IO TmpFs -> (TmpFs -> IO ()) -> (TmpFs -> IO a) -> IO a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO TmpFs
initialiser TmpFs -> IO ()
finaliser TmpFs -> IO a
act
withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a
withLocalTmpFSMake :: forall a. MakeEnv -> (MakeEnv -> IO a) -> IO a
withLocalTmpFSMake MakeEnv
env MakeEnv -> IO a
k =
TmpFs -> (TmpFs -> IO a) -> IO a
forall a. TmpFs -> (TmpFs -> IO a) -> IO a
withLocalTmpFS (HscEnv -> TmpFs
hsc_tmpfs (MakeEnv -> HscEnv
hsc_env MakeEnv
env)) ((TmpFs -> IO a) -> IO a) -> (TmpFs -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \TmpFs
lcl_tmpfs
-> MakeEnv -> IO a
k (MakeEnv
env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }})
runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()
runAllPipelines WorkerLimit
worker_limit MakeEnv
env [MakeAction]
acts = do
let single_worker :: Bool
single_worker = WorkerLimit -> Bool
isWorkerLimitSequential WorkerLimit
worker_limit
spawn_actions :: IO [ThreadId]
spawn_actions :: IO [ThreadId]
spawn_actions = if Bool
single_worker
then (ThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
:[]) (ThreadId -> [ThreadId]) -> IO ThreadId -> IO [ThreadId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> IO [()] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [()] -> IO ()) -> IO [()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> MakeEnv -> [MakeAction] -> IO [()]
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 IO a -> IO a
forall a. IO a -> IO a
unmask) MakeEnv
env [MakeAction]
acts)
else (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> MakeEnv -> [MakeAction] -> IO [ThreadId]
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 = (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread [ThreadId]
tids
IO [ThreadId]
-> ([ThreadId] -> IO ()) -> ([ThreadId] -> IO ()) -> IO ()
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
MC.bracket IO [ThreadId]
spawn_actions [ThreadId] -> IO ()
kill_actions (([ThreadId] -> IO ()) -> IO ()) -> ([ThreadId] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[ThreadId]
_ -> do
(MakeAction -> IO ()) -> [MakeAction] -> IO ()
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 [] = [a] -> IO [a]
forall a. a -> IO a
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 <- MakeEnv -> (MakeEnv -> IO a) -> IO a
forall a. MakeEnv -> (MakeEnv -> IO a) -> IO a
withLocalTmpFSMake MakeEnv
env ((MakeEnv -> IO a) -> IO a) -> (MakeEnv -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \MakeEnv
lcl_env ->
((forall a. IO a -> IO a) -> IO ()) -> IO a
fork_thread (((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> (do
Maybe a
mres <- (IO (Maybe a) -> IO (Maybe a)
forall a. IO a -> IO a
unmask (IO (Maybe a) -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ MakeEnv -> RunMakeM a -> IO (Maybe a)
forall a. MakeEnv -> RunMakeM a -> IO (Maybe a)
run_pipeline MakeEnv
lcl_env RunMakeM a
act)
IO (Maybe a) -> IO () -> IO (Maybe a)
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`MC.onException` (MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
res_var Maybe a
forall a. Maybe a
Nothing)
MVar (Maybe a) -> Maybe a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe a)
res_var Maybe a
mres)
[a]
threads <- (((forall a. IO a -> IO a) -> IO ()) -> IO a)
-> MakeEnv -> [MakeAction] -> IO [a]
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
threads)
where
run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a)
run_pipeline :: forall a. MakeEnv -> RunMakeM a -> IO (Maybe a)
run_pipeline MakeEnv
env RunMakeM a
p = MaybeT IO a -> IO (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (RunMakeM a -> MakeEnv -> MaybeT IO a
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) = () () -> IO (Maybe a) -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MVar (Maybe a) -> IO (Maybe a)
forall a. MVar a -> IO a
readMVar MVar (Maybe a)
mvar