{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
module GhcMake(
depanal, depanalPartial,
load, load', LoadHowMuch(..),
downsweep,
topSortModuleGraph,
ms_home_srcimps, ms_home_imps,
IsBoot(..),
summariseModule,
hscSourceToIsBoot,
findExtraSigImports,
implicitRequirements,
noModError, cyclicModuleErr,
moduleGraphNodes, SummaryNode
) where
#include "HsVersions.h"
import GhcPrelude
import qualified Linker ( unload )
import DriverPhases
import DriverPipeline
import DynFlags
import ErrUtils
import Finder
import GhcMonad
import HeaderInfo
import HscTypes
import Module
import TcIface ( typecheckIface )
import TcRnMonad ( initIfaceCheck )
import HscMain
import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag )
import BasicTypes
import Digraph
import Exception ( tryIO, gbracket, gfinally )
import FastString
import Maybes ( expectJust )
import Name
import MonadUtils ( allM, MonadIO )
import Outputable
import Panic
import SrcLoc
import StringBuffer
import UniqFM
import UniqDSet
import TcBackpack
import Packages
import UniqSet
import Util
import NameEnv
import FileCleanup
import qualified GHC.LanguageExtensions as LangExt
import Data.Either ( rights, partitionEithers )
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import qualified FiniteMap as Map ( insertListWith )
import Control.Concurrent ( forkIOWithUnmask, killThread )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import Data.IORef
import Data.List
import qualified Data.List as List
import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
import System.Directory
import System.FilePath
import System.IO ( fixIO )
import System.IO.Error ( isDoesNotExistError )
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
label_self :: String -> IO ()
label_self :: String -> IO ()
label_self thread_name :: String
thread_name = do
ThreadId
self_tid <- IO ThreadId
CC.myThreadId
ThreadId -> String -> IO ()
CC.labelThread ThreadId
self_tid String
thread_name
depanal :: GhcMonad m =>
[ModuleName]
-> Bool
-> m ModuleGraph
depanal :: [ModuleName] -> Bool -> m ModuleGraph
depanal excluded_mods :: [ModuleName]
excluded_mods allow_dup_roots :: Bool
allow_dup_roots = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
(errs :: ErrorMessages
errs, mod_graph :: ModuleGraph
mod_graph) <- [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial [ModuleName]
excluded_mods Bool
allow_dup_roots
if ErrorMessages -> Bool
forall a. Bag a -> Bool
isEmptyBag ErrorMessages
errs
then do
HscEnv -> ModuleGraph -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules HscEnv
hsc_env ModuleGraph
mod_graph
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
ModuleGraph -> m ModuleGraph
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraph
mod_graph
else ErrorMessages -> m ModuleGraph
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
errs
depanalPartial
:: GhcMonad m
=> [ModuleName]
-> Bool
-> m (ErrorMessages, ModuleGraph)
depanalPartial :: [ModuleName] -> Bool -> m (ErrorMessages, ModuleGraph)
depanalPartial excluded_mods :: [ModuleName]
excluded_mods allow_dup_roots :: Bool
allow_dup_roots = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
targets :: [Target]
targets = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
old_graph :: ModuleGraph
old_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hsc_env
m DynFlags
-> SDoc
-> ((ErrorMessages, ModuleGraph) -> ())
-> m (ErrorMessages, ModuleGraph)
-> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming (DynFlags -> m DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags) (String -> SDoc
text "Chasing dependencies") (() -> (ErrorMessages, ModuleGraph) -> ()
forall a b. a -> b -> a
const ()) (m (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph))
-> m (ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall a b. (a -> b) -> a -> b
$ do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 ([SDoc] -> SDoc
hcat [
String -> SDoc
text "Chasing modules from: ",
[SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((Target -> SDoc) -> [Target] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Target -> SDoc
pprTarget [Target]
targets))])
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
flushFinderCaches HscEnv
hsc_env
[Either ErrorMessages ModSummary]
mod_summariesE <- IO [Either ErrorMessages ModSummary]
-> m [Either ErrorMessages ModSummary]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Either ErrorMessages ModSummary]
-> m [Either ErrorMessages ModSummary])
-> IO [Either ErrorMessages ModSummary]
-> m [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ModSummary]
downsweep HscEnv
hsc_env (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
old_graph)
[ModuleName]
excluded_mods Bool
allow_dup_roots
let
(errs :: [ErrorMessages]
errs, mod_summaries :: [ModSummary]
mod_summaries) = [Either ErrorMessages ModSummary]
-> ([ErrorMessages], [ModSummary])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages ModSummary]
mod_summariesE
mod_graph :: ModuleGraph
mod_graph = [ModSummary] -> ModuleGraph
mkModuleGraph [ModSummary]
mod_summaries
(ErrorMessages, ModuleGraph) -> m (ErrorMessages, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ErrorMessages] -> ErrorMessages
forall a. [Bag a] -> Bag a
unionManyBags [ErrorMessages]
errs, ModuleGraph
mod_graph)
warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules :: HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules hsc_env :: HscEnv
hsc_env mod_graph :: ModuleGraph
mod_graph =
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingHomeModules DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
missing)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag [ErrMsg
warn])
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
targets :: [TargetId]
targets = (Target -> TargetId) -> [Target] -> [TargetId]
forall a b. (a -> b) -> [a] -> [b]
map Target -> TargetId
targetId (HscEnv -> [Target]
hsc_targets HscEnv
hsc_env)
is_known_module :: ModSummary -> Bool
is_known_module mod :: ModSummary
mod = (TargetId -> Bool) -> [TargetId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModSummary -> TargetId -> Bool
is_my_target ModSummary
mod) [TargetId]
targets
is_my_target :: ModSummary -> TargetId -> Bool
is_my_target mod :: ModSummary
mod (TargetModule name :: ModuleName
name)
= Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
name
is_my_target mod :: ModSummary
mod (TargetFile target_file :: String
target_file _)
| Just mod_file :: String
mod_file <- ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod)
= String
target_file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mod_file Bool -> Bool -> Bool
||
String -> String
addBootSuffix String
target_file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mod_file Bool -> Bool -> Bool
||
String -> ModuleName
mkModuleName ((String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ String -> (String, String)
splitExtension String
target_file)
ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod)
is_my_target _ _ = Bool
False
missing :: [ModuleName]
missing = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
moduleName (Module -> ModuleName)
-> (ModSummary -> Module) -> ModSummary -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod) ([ModSummary] -> [ModuleName]) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
(ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModSummary -> Bool) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Bool
is_known_module) (ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph)
msg :: SDoc
msg
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildingCabalPackage DynFlags
dflags
= SDoc -> Int -> SDoc -> SDoc
hang
(String -> SDoc
text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")
4
([SDoc] -> SDoc
sep ((ModuleName -> SDoc) -> [ModuleName] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
| Bool
otherwise
=
SDoc -> Int -> SDoc -> SDoc
hang
(String -> SDoc
text "Modules are not listed in command line but needed for compilation: ")
4
([SDoc] -> SDoc
sep ((ModuleName -> SDoc) -> [ModuleName] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
missing))
warn :: ErrMsg
warn = WarnReason -> ErrMsg -> ErrMsg
makeIntoWarning
(WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingHomeModules)
(DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
noSrcSpan SDoc
msg)
data LoadHowMuch
= LoadAllTargets
| LoadUpTo ModuleName
| LoadDependenciesOf ModuleName
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load :: LoadHowMuch -> m SuccessFlag
load how_much :: LoadHowMuch
how_much = do
ModuleGraph
mod_graph <- [ModuleName] -> Bool -> m ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
False
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' LoadHowMuch
how_much (Messager -> Maybe Messager
forall a. a -> Maybe a
Just Messager
batchMsg) ModuleGraph
mod_graph
load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' :: LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' how_much :: LoadHowMuch
how_much mHscMessage :: Maybe Messager
mHscMessage mod_graph :: ModuleGraph
mod_graph = do
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
mod_graph }
m ()
forall (m :: * -> *). GhcMonad m => m ()
guessOutputFile
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let hpt1 :: HomePackageTable
hpt1 = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let all_home_mods :: UniqSet ModuleName
all_home_mods =
[ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [ ModSummary -> ModuleName
ms_mod_name ModSummary
s
| ModSummary
s <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mod_graph, Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
s)]
let checkHowMuch :: LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch (LoadUpTo m :: ModuleName
m) = ModuleName -> m SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
MonadIO m =>
ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m
checkHowMuch (LoadDependenciesOf m :: ModuleName
m) = ModuleName -> m SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
MonadIO m =>
ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod ModuleName
m
checkHowMuch _ = m SuccessFlag -> m SuccessFlag
forall a. a -> a
id
checkMod :: ModuleName -> m SuccessFlag -> m SuccessFlag
checkMod m :: ModuleName
m and_then :: m SuccessFlag
and_then
| ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods = m SuccessFlag
and_then
| Bool
otherwise = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
errorMsg DynFlags
dflags (String -> SDoc
text "no such module:" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m))
SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
LoadHowMuch -> m SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
MonadIO m =>
LoadHowMuch -> m SuccessFlag -> m SuccessFlag
checkHowMuch LoadHowMuch
how_much (m SuccessFlag -> m SuccessFlag) -> m SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ do
let mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps :: [SCC ModSummary]
mg2_with_srcimps = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
True ModuleGraph
mod_graph Maybe ModuleName
forall a. Maybe a
Nothing
[SCC ModSummary] -> m ()
forall (m :: * -> *). GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports [SCC ModSummary]
mg2_with_srcimps
let
stable_mods :: (UniqSet ModuleName, UniqSet ModuleName)
stable_mods@(stable_obj :: UniqSet ModuleName
stable_obj,stable_bco :: UniqSet ModuleName
stable_bco)
= HomePackageTable
-> [SCC ModSummary]
-> UniqSet ModuleName
-> (UniqSet ModuleName, UniqSet ModuleName)
checkStability HomePackageTable
hpt1 [SCC ModSummary]
mg2_with_srcimps UniqSet ModuleName
all_home_mods
pruned_hpt :: HomePackageTable
pruned_hpt = HomePackageTable
-> [ModSummary]
-> (UniqSet ModuleName, UniqSet ModuleName)
-> HomePackageTable
pruneHomePackageTable HomePackageTable
hpt1
([SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs [SCC ModSummary]
mg2_with_srcimps)
(UniqSet ModuleName, UniqSet ModuleName)
stable_mods
HomePackageTable
_ <- IO HomePackageTable -> m HomePackageTable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomePackageTable -> m HomePackageTable)
-> IO HomePackageTable -> m HomePackageTable
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> IO HomePackageTable
forall a. a -> IO a
evaluate HomePackageTable
pruned_hpt
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> HscEnv
discardIC (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
pruned_hpt }
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (String -> SDoc
text "Stable obj:" SDoc -> SDoc -> SDoc
<+> UniqSet ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_obj SDoc -> SDoc -> SDoc
$$
String -> SDoc
text "Stable BCO:" SDoc -> SDoc -> SDoc
<+> UniqSet ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqSet ModuleName
stable_bco)
let stable_linkables :: [Linkable]
stable_linkables = [ Linkable
linkable
| ModuleName
m <- UniqSet ModuleName -> [ModuleName]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_obj [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++
UniqSet ModuleName -> [ModuleName]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ModuleName
stable_bco,
Just hmi :: HomeModInfo
hmi <- [HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
pruned_hpt ModuleName
m],
Just linkable :: Linkable
linkable <- [HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi] ]
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [Linkable] -> IO ()
unload HscEnv
hsc_env [Linkable]
stable_linkables
let full_mg :: [SCC ModSummary]
full_mg :: [SCC ModSummary]
full_mg = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe ModuleName
forall a. Maybe a
Nothing
maybe_top_mod :: Maybe ModuleName
maybe_top_mod = case LoadHowMuch
how_much of
LoadUpTo m :: ModuleName
m -> ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
m
LoadDependenciesOf m :: ModuleName
m -> ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
m
_ -> Maybe ModuleName
forall a. Maybe a
Nothing
partial_mg0 :: [SCC ModSummary]
partial_mg0 :: [SCC ModSummary]
partial_mg0 = Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
False ModuleGraph
mod_graph Maybe ModuleName
maybe_top_mod
partial_mg :: [SCC ModSummary]
partial_mg
| LoadDependenciesOf _mod :: ModuleName
_mod <- LoadHowMuch
how_much
= ASSERT( case last partial_mg0 of
AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
[SCC ModSummary] -> [SCC ModSummary]
forall a. [a] -> [a]
List.init [SCC ModSummary]
partial_mg0
| Bool
otherwise
= [SCC ModSummary]
partial_mg0
stable_mg :: [SCC ModSummary]
stable_mg =
[ ModSummary -> SCC ModSummary
forall vertex. vertex -> SCC vertex
AcyclicSCC ModSummary
ms
| AcyclicSCC ms :: ModSummary
ms <- [SCC ModSummary]
full_mg,
ModSummary -> Bool
stable_mod_summary ModSummary
ms ]
stable_mod_summary :: ModSummary -> Bool
stable_mod_summary ms :: ModSummary
ms =
ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj Bool -> Bool -> Bool
||
ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco
unstable_mg :: [SCC ModSummary]
unstable_mg = (SCC ModSummary -> Bool) -> [SCC ModSummary] -> [SCC ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter SCC ModSummary -> Bool
not_stable [SCC ModSummary]
partial_mg
where not_stable :: SCC ModSummary -> Bool
not_stable (CyclicSCC _) = Bool
True
not_stable (AcyclicSCC ms :: ModSummary
ms)
= Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ModSummary -> Bool
stable_mod_summary ModSummary
ms
mg :: [SCC ModSummary]
mg = [SCC ModSummary]
stable_mg [SCC ModSummary] -> [SCC ModSummary] -> [SCC ModSummary]
forall a. [a] -> [a] -> [a]
++ [SCC ModSummary]
unstable_mg
let cleanup :: HscEnv -> IO ()
cleanup = DynFlags -> IO ()
cleanCurrentModuleTempFiles (DynFlags -> IO ()) -> (HscEnv -> DynFlags) -> HscEnv -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> DynFlags
hsc_dflags
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "Ready for upsweep")
2 ([SCC ModSummary] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SCC ModSummary]
mg))
Int
n_jobs <- case DynFlags -> Maybe Int
parMakeCount DynFlags
dflags of
Nothing -> IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumProcessors
Just n :: Int
n -> Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
let upsweep_fn :: Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
upsweep_fn | Int
n_jobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 = Int
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
forall (m :: * -> *).
GhcMonad m =>
Int
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
parUpsweep Int
n_jobs
| Bool
otherwise = Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
forall (m :: * -> *).
GhcMonad m =>
Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
upsweep
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }
(upsweep_ok :: SuccessFlag
upsweep_ok, modsUpswept :: [ModSummary]
modsUpswept)
<- Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
upsweep_fn Maybe Messager
mHscMessage HomePackageTable
pruned_hpt (UniqSet ModuleName, UniqSet ModuleName)
stable_mods HscEnv -> IO ()
cleanup [SCC ModSummary]
mg
let modsDone :: [ModSummary]
modsDone = [ModSummary] -> [ModSummary]
forall a. [a] -> [a]
reverse [ModSummary]
modsUpswept
if SuccessFlag -> Bool
succeeded SuccessFlag
upsweep_ok
then
do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (String -> SDoc
text "Upsweep completely successful.")
HscEnv
hsc_env1 <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
cleanCurrentModuleTempFiles DynFlags
dflags
let ofile :: Maybe String
ofile = DynFlags -> Maybe String
outputFile DynFlags
dflags
let no_hs_main :: Bool
no_hs_main = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_NoHsMain DynFlags
dflags
let
main_mod :: Module
main_mod = DynFlags -> Module
mainModIs DynFlags
dflags
a_root_is_Main :: Bool
a_root_is_Main = ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph
mod_graph Module
main_mod
do_linking :: Bool
do_linking = Bool
a_root_is_Main Bool -> Bool -> Bool
|| Bool
no_hs_main Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkDynLib Bool -> Bool -> Bool
|| DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkStaticLib
SuccessFlag
linkresult <- IO SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SuccessFlag -> m SuccessFlag)
-> IO SuccessFlag -> m SuccessFlag
forall a b. (a -> b) -> a -> b
$ GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag
link (DynFlags -> GhcLink
ghcLink DynFlags
dflags) DynFlags
dflags Bool
do_linking (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1)
if DynFlags -> GhcLink
ghcLink DynFlags
dflags GhcLink -> GhcLink -> Bool
forall a. Eq a => a -> a -> Bool
== GhcLink
LinkBinary Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
ofile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
do_linking
then do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
errorMsg DynFlags
dflags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text
("output was redirected with -o, " String -> String -> String
forall a. [a] -> [a] -> [a]
++
"but no output will be generated\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
"because there is no " String -> String -> String
forall a. [a] -> [a] -> [a]
++
ModuleName -> String
moduleNameString (Module -> ModuleName
moduleName Module
main_mod) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " module.")
SuccessFlag -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
Failed SuccessFlag
linkresult
else
SuccessFlag -> SuccessFlag -> m SuccessFlag
forall (m :: * -> *).
GhcMonad m =>
SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish SuccessFlag
Succeeded SuccessFlag
linkresult
else
do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (String -> SDoc
text "Upsweep partially successful.")
let modsDone_names :: [Module]
modsDone_names
= (ModSummary -> Module) -> [ModSummary] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> Module
ms_mod [ModSummary]
modsDone
let mods_to_zap_names :: Set Module
mods_to_zap_names
= [Module] -> [SCC ModSummary] -> Set Module
findPartiallyCompletedCycles [Module]
modsDone_names
[SCC ModSummary]
mg2_with_srcimps
let (mods_to_clean :: [ModSummary]
mods_to_clean, mods_to_keep :: [ModSummary]
mods_to_keep) =
(ModSummary -> Bool)
-> [ModSummary] -> ([ModSummary], [ModSummary])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Module -> Set Module -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
mods_to_zap_names)(Module -> Bool) -> (ModSummary -> Module) -> ModSummary -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModSummary -> Module
ms_mod) [ModSummary]
modsDone
HscEnv
hsc_env1 <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let hpt4 :: HomePackageTable
hpt4 = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env1
unneeded_temps :: [String]
unneeded_temps = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
ms_hspp_file String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
object_files
| ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod, String
ms_hspp_file :: ModSummary -> String
ms_hspp_file :: String
ms_hspp_file} <- [ModSummary]
mods_to_clean
, let object_files :: [String]
object_files = [String] -> (Linkable -> [String]) -> Maybe Linkable -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Linkable -> [String]
linkableObjs (Maybe Linkable -> [String]) -> Maybe Linkable -> [String]
forall a b. (a -> b) -> a -> b
$
HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt4 (Module -> ModuleName
moduleName Module
ms_mod)
Maybe HomeModInfo
-> (HomeModInfo -> Maybe Linkable) -> Maybe Linkable
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HomeModInfo -> Maybe Linkable
hm_linkable
]
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
DynFlags -> TempFileLifetime -> [String] -> IO ()
changeTempFilesLifetime DynFlags
dflags TempFileLifetime
TFL_CurrentModule [String]
unneeded_temps
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO ()
cleanCurrentModuleTempFiles DynFlags
dflags
let hpt5 :: HomePackageTable
hpt5 = [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
mods_to_keep)
HomePackageTable
hpt4
let just_linkables :: Bool
just_linkables =
GhcLink -> Bool
isNoLink (DynFlags -> GhcLink
ghcLink DynFlags
dflags)
Bool -> Bool -> Bool
|| (HomeModInfo -> Bool) -> HomePackageTable -> Bool
allHpt (Maybe Linkable -> Bool
forall a. Maybe a -> Bool
isJust(Maybe Linkable -> Bool)
-> (HomeModInfo -> Maybe Linkable) -> HomeModInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> Maybe Linkable
hm_linkable)
((HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable
filterHpt ((HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile)(HscSource -> Bool)
-> (HomeModInfo -> HscSource) -> HomeModInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModIface -> HscSource
mi_hsc_src(ModIface -> HscSource)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> HscSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
.HomeModInfo -> ModIface
hm_iface)
HomePackageTable
hpt5)
ASSERT( just_linkables ) do
linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5
modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
loadFinish Failed linkresult
loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish :: SuccessFlag -> SuccessFlag -> m SuccessFlag
loadFinish _all_ok :: SuccessFlag
_all_ok Failed
= do HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [Linkable] -> IO ()
unload HscEnv
hsc_env []
(HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardProg
SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
loadFinish all_ok :: SuccessFlag
all_ok Succeeded
= do (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
discardIC
SuccessFlag -> m SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
all_ok
discardProg :: HscEnv -> HscEnv
discardProg :: HscEnv -> HscEnv
discardProg hsc_env :: HscEnv
hsc_env
= HscEnv -> HscEnv
discardIC (HscEnv -> HscEnv) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv
hsc_env { hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG
, hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable }
discardIC :: HscEnv -> HscEnv
discardIC :: HscEnv -> HscEnv
discardIC hsc_env :: HscEnv
hsc_env
= HscEnv
hsc_env { hsc_IC :: InteractiveContext
hsc_IC = InteractiveContext
empty_ic { ic_int_print :: Name
ic_int_print = Name
new_ic_int_print
, ic_monad :: Name
ic_monad = Name
new_ic_monad } }
where
!new_ic_int_print :: Name
new_ic_int_print = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_int_print
!new_ic_monad :: Name
new_ic_monad = (InteractiveContext -> Name) -> Name
keep_external_name InteractiveContext -> Name
ic_monad
dflags :: DynFlags
dflags = InteractiveContext -> DynFlags
ic_dflags InteractiveContext
old_ic
old_ic :: InteractiveContext
old_ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
empty_ic :: InteractiveContext
empty_ic = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
keep_external_name :: (InteractiveContext -> Name) -> Name
keep_external_name ic_name :: InteractiveContext -> Name
ic_name
| UnitId -> Name -> Bool
nameIsFromExternalPackage UnitId
this_pkg Name
old_name = Name
old_name
| Bool
otherwise = InteractiveContext -> Name
ic_name InteractiveContext
empty_ic
where
this_pkg :: UnitId
this_pkg = DynFlags -> UnitId
thisPackage DynFlags
dflags
old_name :: Name
old_name = InteractiveContext -> Name
ic_name InteractiveContext
old_ic
guessOutputFile :: GhcMonad m => m ()
guessOutputFile :: m ()
guessOutputFile = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \env :: HscEnv
env ->
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
!mod_graph :: ModuleGraph
mod_graph = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
env
mainModuleSrcPath :: Maybe String
mainModuleSrcPath :: Maybe String
mainModuleSrcPath = do
ModSummary
ms <- ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph
mod_graph (DynFlags -> Module
mainModIs DynFlags
dflags)
ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)
name :: Maybe String
name = (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
dropExtension Maybe String
mainModuleSrcPath
name_exe :: Maybe String
name_exe = do
#if defined(mingw32_HOST_OS)
name' <- fmap (<.> "exe") name
#else
String
name' <- Maybe String
name
#endif
String
mainModuleSrcPath' <- Maybe String
mainModuleSrcPath
if String
name' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mainModuleSrcPath'
then GhcException -> Maybe String
forall a. GhcException -> a
throwGhcException (GhcException -> Maybe String)
-> (String -> GhcException) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcException
UsageError (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
"default output name would overwrite the input file; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
"must specify -o explicitly"
else String -> Maybe String
forall a. a -> Maybe a
Just String
name'
in
case DynFlags -> Maybe String
outputFile DynFlags
dflags of
Just _ -> HscEnv
env
Nothing -> HscEnv
env { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags { outputFile :: Maybe String
outputFile = Maybe String
name_exe } }
pruneHomePackageTable :: HomePackageTable
-> [ModSummary]
-> StableModules
-> HomePackageTable
pruneHomePackageTable :: HomePackageTable
-> [ModSummary]
-> (UniqSet ModuleName, UniqSet ModuleName)
-> HomePackageTable
pruneHomePackageTable hpt :: HomePackageTable
hpt summ :: [ModSummary]
summ (stable_obj :: UniqSet ModuleName
stable_obj, stable_bco :: UniqSet ModuleName
stable_bco)
= (HomeModInfo -> HomeModInfo)
-> HomePackageTable -> HomePackageTable
mapHpt HomeModInfo -> HomeModInfo
prune HomePackageTable
hpt
where prune :: HomeModInfo -> HomeModInfo
prune hmi :: HomeModInfo
hmi
| ModuleName -> Bool
is_stable ModuleName
modl = HomeModInfo
hmi'
| Bool
otherwise = HomeModInfo
hmi'{ hm_details :: ModDetails
hm_details = ModDetails
emptyModDetails }
where
modl :: ModuleName
modl = Module -> ModuleName
moduleName (ModIface -> Module
mi_module (HomeModInfo -> ModIface
hm_iface HomeModInfo
hmi))
hmi' :: HomeModInfo
hmi' | Just l :: Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi, Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< ModSummary -> UTCTime
ms_hs_date ModSummary
ms
= HomeModInfo
hmi{ hm_linkable :: Maybe Linkable
hm_linkable = Maybe Linkable
forall a. Maybe a
Nothing }
| Bool
otherwise
= HomeModInfo
hmi
where ms :: ModSummary
ms = String -> Maybe ModSummary -> ModSummary
forall a. HasCallStack => String -> Maybe a -> a
expectJust "prune" (UniqFM ModSummary -> ModuleName -> Maybe ModSummary
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM ModSummary
ms_map ModuleName
modl)
ms_map :: UniqFM ModSummary
ms_map = [(ModuleName, ModSummary)] -> UniqFM ModSummary
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
listToUFM [(ModSummary -> ModuleName
ms_mod_name ModSummary
ms, ModSummary
ms) | ModSummary
ms <- [ModSummary]
summ]
is_stable :: ModuleName -> Bool
is_stable m :: ModuleName
m =
ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj Bool -> Bool -> Bool
||
ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set Module
findPartiallyCompletedCycles modsDone :: [Module]
modsDone theGraph :: [SCC ModSummary]
theGraph
= [Set Module] -> Set Module
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
[Set Module
mods_in_this_cycle
| CyclicSCC vs :: [ModSummary]
vs <- [SCC ModSummary]
theGraph
, let names_in_this_cycle :: Set Module
names_in_this_cycle = [Module] -> Set Module
forall a. Ord a => [a] -> Set a
Set.fromList ((ModSummary -> Module) -> [ModSummary] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> Module
ms_mod [ModSummary]
vs)
mods_in_this_cycle :: Set Module
mods_in_this_cycle =
Set Module -> Set Module -> Set Module
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection ([Module] -> Set Module
forall a. Ord a => [a] -> Set a
Set.fromList [Module]
modsDone) Set Module
names_in_this_cycle
, Set Module -> Int
forall a. Set a -> Int
Set.size Set Module
mods_in_this_cycle Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Set Module -> Int
forall a. Set a -> Int
Set.size Set Module
names_in_this_cycle]
unload :: HscEnv -> [Linkable] -> IO ()
unload :: HscEnv -> [Linkable] -> IO ()
unload hsc_env :: HscEnv
hsc_env stable_linkables :: [Linkable]
stable_linkables
= case DynFlags -> GhcLink
ghcLink (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) of
LinkInMemory -> HscEnv -> [Linkable] -> IO ()
Linker.unload HscEnv
hsc_env [Linkable]
stable_linkables
_other :: GhcLink
_other -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
type StableModules =
( UniqSet ModuleName
, UniqSet ModuleName
)
checkStability
:: HomePackageTable
-> [SCC ModSummary]
-> UniqSet ModuleName
-> StableModules
checkStability :: HomePackageTable
-> [SCC ModSummary]
-> UniqSet ModuleName
-> (UniqSet ModuleName, UniqSet ModuleName)
checkStability hpt :: HomePackageTable
hpt sccs :: [SCC ModSummary]
sccs all_home_mods :: UniqSet ModuleName
all_home_mods =
((UniqSet ModuleName, UniqSet ModuleName)
-> SCC ModSummary -> (UniqSet ModuleName, UniqSet ModuleName))
-> (UniqSet ModuleName, UniqSet ModuleName)
-> [SCC ModSummary]
-> (UniqSet ModuleName, UniqSet ModuleName)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (UniqSet ModuleName, UniqSet ModuleName)
-> SCC ModSummary -> (UniqSet ModuleName, UniqSet ModuleName)
checkSCC (UniqSet ModuleName
forall a. UniqSet a
emptyUniqSet, UniqSet ModuleName
forall a. UniqSet a
emptyUniqSet) [SCC ModSummary]
sccs
where
checkSCC :: StableModules -> SCC ModSummary -> StableModules
checkSCC :: (UniqSet ModuleName, UniqSet ModuleName)
-> SCC ModSummary -> (UniqSet ModuleName, UniqSet ModuleName)
checkSCC (stable_obj :: UniqSet ModuleName
stable_obj, stable_bco :: UniqSet ModuleName
stable_bco) scc0 :: SCC ModSummary
scc0
| Bool
stableObjects = (UniqSet ModuleName -> [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet ModuleName
stable_obj [ModuleName]
scc_mods, UniqSet ModuleName
stable_bco)
| Bool
stableBCOs = (UniqSet ModuleName
stable_obj, UniqSet ModuleName -> [ModuleName] -> UniqSet ModuleName
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
addListToUniqSet UniqSet ModuleName
stable_bco [ModuleName]
scc_mods)
| Bool
otherwise = (UniqSet ModuleName
stable_obj, UniqSet ModuleName
stable_bco)
where
scc :: [ModSummary]
scc = SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC SCC ModSummary
scc0
scc_mods :: [ModuleName]
scc_mods = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
scc
home_module :: ModuleName -> Bool
home_module m :: ModuleName
m =
ModuleName
m ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
all_home_mods Bool -> Bool -> Bool
&& ModuleName
m ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
scc_mods
scc_allimps :: [ModuleName]
scc_allimps = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ((ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
home_module ((ModSummary -> [ModuleName]) -> [ModSummary] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [ModuleName]
ms_home_allimps [ModSummary]
scc))
stable_obj_imps :: [Bool]
stable_obj_imps = (ModuleName -> Bool) -> [ModuleName] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj) [ModuleName]
scc_allimps
stable_bco_imps :: [Bool]
stable_bco_imps = (ModuleName -> Bool) -> [ModuleName] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco) [ModuleName]
scc_allimps
stableObjects :: Bool
stableObjects =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
stable_obj_imps
Bool -> Bool -> Bool
&& (ModSummary -> Bool) -> [ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModSummary -> Bool
object_ok [ModSummary]
scc
stableBCOs :: Bool
stableBCOs =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(||) [Bool]
stable_obj_imps [Bool]
stable_bco_imps)
Bool -> Bool -> Bool
&& (ModSummary -> Bool) -> [ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModSummary -> Bool
bco_ok [ModSummary]
scc
object_ok :: ModSummary -> Bool
object_ok ms :: ModSummary
ms
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) = Bool
False
| Just t :: UTCTime
t <- ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
ms = UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
ms
Bool -> Bool -> Bool
&& UTCTime -> Bool
same_as_prev UTCTime
t
| Bool
otherwise = Bool
False
where
same_as_prev :: UTCTime -> Bool
same_as_prev t :: UTCTime
t = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) of
Just hmi :: HomeModInfo
hmi | Just l :: Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi
-> Linkable -> Bool
isObjectLinkable Linkable
l Bool -> Bool -> Bool
&& UTCTime
t UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== Linkable -> UTCTime
linkableTime Linkable
l
_other :: Maybe HomeModInfo
_other -> Bool
True
bco_ok :: ModSummary -> Bool
bco_ok ms :: ModSummary
ms
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) = Bool
False
| Bool
otherwise = case HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) of
Just hmi :: HomeModInfo
hmi | Just l :: Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi ->
Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
l) Bool -> Bool -> Bool
&&
Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
ms
_other :: Maybe HomeModInfo
_other -> Bool
False
data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
!(MVar ())
type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]
buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph [] = (CompilationGraph, Maybe [ModSummary])
-> IO (CompilationGraph, Maybe [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe [ModSummary]
forall a. Maybe a
Nothing)
buildCompGraph (scc :: SCC ModSummary
scc:sccs :: [SCC ModSummary]
sccs) = case SCC ModSummary
scc of
AcyclicSCC ms :: ModSummary
ms -> do
MVar SuccessFlag
mvar <- IO (MVar SuccessFlag)
forall a. IO (MVar a)
newEmptyMVar
LogQueue
log_queue <- do
IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
ref <- [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> IO
(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)])
forall a. a -> IO (IORef a)
newIORef []
MVar ()
sem <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
LogQueue -> IO LogQueue
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> MVar () -> LogQueue
LogQueue IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
ref MVar ()
sem)
(rest :: CompilationGraph
rest,cycle :: Maybe [ModSummary]
cycle) <- [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph [SCC ModSummary]
sccs
(CompilationGraph, Maybe [ModSummary])
-> IO (CompilationGraph, Maybe [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModSummary
ms,MVar SuccessFlag
mvar,LogQueue
log_queue)(ModSummary, MVar SuccessFlag, LogQueue)
-> CompilationGraph -> CompilationGraph
forall a. a -> [a] -> [a]
:CompilationGraph
rest, Maybe [ModSummary]
cycle)
CyclicSCC mss :: [ModSummary]
mss -> (CompilationGraph, Maybe [ModSummary])
-> IO (CompilationGraph, Maybe [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [ModSummary] -> Maybe [ModSummary]
forall a. a -> Maybe a
Just [ModSummary]
mss)
type BuildModule = (Module, IsBoot)
data IsBoot = IsBoot | NotBoot
deriving (Eq IsBoot
Eq IsBoot =>
(IsBoot -> IsBoot -> Ordering)
-> (IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> IsBoot)
-> (IsBoot -> IsBoot -> IsBoot)
-> Ord IsBoot
IsBoot -> IsBoot -> Bool
IsBoot -> IsBoot -> Ordering
IsBoot -> IsBoot -> IsBoot
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IsBoot -> IsBoot -> IsBoot
$cmin :: IsBoot -> IsBoot -> IsBoot
max :: IsBoot -> IsBoot -> IsBoot
$cmax :: IsBoot -> IsBoot -> IsBoot
>= :: IsBoot -> IsBoot -> Bool
$c>= :: IsBoot -> IsBoot -> Bool
> :: IsBoot -> IsBoot -> Bool
$c> :: IsBoot -> IsBoot -> Bool
<= :: IsBoot -> IsBoot -> Bool
$c<= :: IsBoot -> IsBoot -> Bool
< :: IsBoot -> IsBoot -> Bool
$c< :: IsBoot -> IsBoot -> Bool
compare :: IsBoot -> IsBoot -> Ordering
$ccompare :: IsBoot -> IsBoot -> Ordering
$cp1Ord :: Eq IsBoot
Ord, IsBoot -> IsBoot -> Bool
(IsBoot -> IsBoot -> Bool)
-> (IsBoot -> IsBoot -> Bool) -> Eq IsBoot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsBoot -> IsBoot -> Bool
$c/= :: IsBoot -> IsBoot -> Bool
== :: IsBoot -> IsBoot -> Bool
$c== :: IsBoot -> IsBoot -> Bool
Eq, Int -> IsBoot -> String -> String
[IsBoot] -> String -> String
IsBoot -> String
(Int -> IsBoot -> String -> String)
-> (IsBoot -> String)
-> ([IsBoot] -> String -> String)
-> Show IsBoot
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [IsBoot] -> String -> String
$cshowList :: [IsBoot] -> String -> String
show :: IsBoot -> String
$cshow :: IsBoot -> String
showsPrec :: Int -> IsBoot -> String -> String
$cshowsPrec :: Int -> IsBoot -> String -> String
Show, ReadPrec [IsBoot]
ReadPrec IsBoot
Int -> ReadS IsBoot
ReadS [IsBoot]
(Int -> ReadS IsBoot)
-> ReadS [IsBoot]
-> ReadPrec IsBoot
-> ReadPrec [IsBoot]
-> Read IsBoot
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IsBoot]
$creadListPrec :: ReadPrec [IsBoot]
readPrec :: ReadPrec IsBoot
$creadPrec :: ReadPrec IsBoot
readList :: ReadS [IsBoot]
$creadList :: ReadS [IsBoot]
readsPrec :: Int -> ReadS IsBoot
$creadsPrec :: Int -> ReadS IsBoot
Read)
hscSourceToIsBoot :: HscSource -> IsBoot
hscSourceToIsBoot :: HscSource -> IsBoot
hscSourceToIsBoot HsBootFile = IsBoot
IsBoot
hscSourceToIsBoot _ = IsBoot
NotBoot
mkBuildModule :: ModSummary -> BuildModule
mkBuildModule :: ModSummary -> BuildModule
mkBuildModule ms :: ModSummary
ms = (ModSummary -> Module
ms_mod ModSummary
ms, if ModSummary -> Bool
isBootSummary ModSummary
ms then IsBoot
IsBoot else IsBoot
NotBoot)
parUpsweep
:: GhcMonad m
=> Int
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag,
[ModSummary])
parUpsweep :: Int
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
parUpsweep n_jobs :: Int
n_jobs mHscMessage :: Maybe Messager
mHscMessage old_hpt :: HomePackageTable
old_hpt stable_mods :: (UniqSet ModuleName, UniqSet ModuleName)
stable_mods cleanup :: HscEnv -> IO ()
cleanup sccs :: [SCC ModSummary]
sccs = do
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DynFlags -> [UnitId]
unitIdsToCheck DynFlags
dflags))) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
GhcException -> m ()
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError "Backpack typechecking not supported with -j")
MVar HscEnv
hsc_env_var <- IO (MVar HscEnv) -> m (MVar HscEnv)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar HscEnv) -> m (MVar HscEnv))
-> IO (MVar HscEnv) -> m (MVar HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO (MVar HscEnv)
forall a. a -> IO (MVar a)
newMVar HscEnv
hsc_env
IORef HomePackageTable
old_hpt_var <- IO (IORef HomePackageTable) -> m (IORef HomePackageTable)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef HomePackageTable) -> m (IORef HomePackageTable))
-> IO (IORef HomePackageTable) -> m (IORef HomePackageTable)
forall a b. (a -> b) -> a -> b
$ HomePackageTable -> IO (IORef HomePackageTable)
forall a. a -> IO (IORef a)
newIORef HomePackageTable
old_hpt
QSem
par_sem <- IO QSem -> m QSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO QSem -> m QSem) -> IO QSem -> m QSem
forall a b. (a -> b) -> a -> b
$ Int -> IO QSem
newQSem Int
n_jobs
let updNumCapabilities :: m Int
updNumCapabilities = IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ do
Int
n_capabilities <- IO Int
getNumCapabilities
Int
n_cpus <- IO Int
getNumProcessors
let n_caps :: Int
n_caps = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n_jobs Int
n_cpus
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n_capabilities Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
n_caps
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n_capabilities
let resetNumCapabilities :: Int -> m ()
resetNumCapabilities orig_n :: Int
orig_n = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
setNumCapabilities Int
orig_n
m Int
-> (Int -> m ())
-> (Int -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket m Int
updNumCapabilities Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
resetNumCapabilities ((Int -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary]))
-> (Int -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary])
forall a b. (a -> b) -> a -> b
$ \_ -> do
let finallySyncSession :: m a -> m a
finallySyncSession io :: m a
io = m a
io m a -> m () -> m a
forall (m :: * -> *) a b. ExceptionMonad m => m a -> m b -> m a
`gfinally` do
HscEnv
hsc_env <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ MVar HscEnv -> IO HscEnv
forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env
m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. GhcMonad m => m a -> m a
finallySyncSession (m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary]))
-> m (SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall a b. (a -> b) -> a -> b
$ do
(comp_graph :: CompilationGraph
comp_graph,cycle :: Maybe [ModSummary]
cycle) <- IO (CompilationGraph, Maybe [ModSummary])
-> m (CompilationGraph, Maybe [ModSummary])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CompilationGraph, Maybe [ModSummary])
-> m (CompilationGraph, Maybe [ModSummary]))
-> IO (CompilationGraph, Maybe [ModSummary])
-> m (CompilationGraph, Maybe [ModSummary])
forall a b. (a -> b) -> a -> b
$ [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph [SCC ModSummary]
sccs
let comp_graph_w_idx :: [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx = CompilationGraph
-> [Int] -> [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip CompilationGraph
comp_graph [1..]
let graph :: [ModSummary]
graph = ((ModSummary, MVar SuccessFlag, LogQueue) -> ModSummary)
-> CompilationGraph -> [ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map (ModSummary, MVar SuccessFlag, LogQueue) -> ModSummary
forall a b c. (a, b, c) -> a
fstOf3 (CompilationGraph -> CompilationGraph
forall a. [a] -> [a]
reverse CompilationGraph
comp_graph)
boot_modules :: ModuleSet
boot_modules = [Module] -> ModuleSet
mkModuleSet [ModSummary -> Module
ms_mod ModSummary
ms | ModSummary
ms <- [ModSummary]
graph, ModSummary -> Bool
isBootSummary ModSummary
ms]
comp_graph_loops :: [[BuildModule]]
comp_graph_loops = [ModSummary] -> ModuleSet -> [[BuildModule]]
go [ModSummary]
graph ModuleSet
boot_modules
where
remove :: ModSummary -> ModuleSet -> ModuleSet
remove ms :: ModSummary
ms bm :: ModuleSet
bm
| ModSummary -> Bool
isBootSummary ModSummary
ms = ModuleSet -> Module -> ModuleSet
delModuleSet ModuleSet
bm (ModSummary -> Module
ms_mod ModSummary
ms)
| Bool
otherwise = ModuleSet
bm
go :: [ModSummary] -> ModuleSet -> [[BuildModule]]
go [] _ = []
go mg :: [ModSummary]
mg@(ms :: ModSummary
ms:mss :: [ModSummary]
mss) boot_modules :: ModuleSet
boot_modules
| Just loop :: [ModSummary]
loop <- ModSummary
-> [ModSummary] -> (Module -> Bool) -> Maybe [ModSummary]
getModLoop ModSummary
ms [ModSummary]
mg (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleSet
boot_modules)
= (ModSummary -> BuildModule) -> [ModSummary] -> [BuildModule]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> BuildModule
mkBuildModule (ModSummary
msModSummary -> [ModSummary] -> [ModSummary]
forall a. a -> [a] -> [a]
:[ModSummary]
loop) [BuildModule] -> [[BuildModule]] -> [[BuildModule]]
forall a. a -> [a] -> [a]
: [ModSummary] -> ModuleSet -> [[BuildModule]]
go [ModSummary]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)
| Bool
otherwise
= [ModSummary] -> ModuleSet -> [[BuildModule]]
go [ModSummary]
mss (ModSummary -> ModuleSet -> ModuleSet
remove ModSummary
ms ModuleSet
boot_modules)
let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
home_mod_map =
[(BuildModule, (MVar SuccessFlag, Int))]
-> Map BuildModule (MVar SuccessFlag, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModSummary -> BuildModule
mkBuildModule ModSummary
ms, (MVar SuccessFlag
mvar, Int
idx))
| ((ms :: ModSummary
ms,mvar :: MVar SuccessFlag
mvar,_),idx :: Int
idx) <- [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx ]
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
label_self "main --make thread"
let { spawnWorkers :: IO [ThreadId]
spawnWorkers = [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
-> (((ModSummary, MVar SuccessFlag, LogQueue), Int) -> IO ThreadId)
-> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((ModSummary, MVar SuccessFlag, LogQueue), Int)]
comp_graph_w_idx ((((ModSummary, MVar SuccessFlag, LogQueue), Int) -> IO ThreadId)
-> IO [ThreadId])
-> (((ModSummary, MVar SuccessFlag, LogQueue), Int) -> IO ThreadId)
-> IO [ThreadId]
forall a b. (a -> b) -> a -> b
$ \((mod :: ModSummary
mod,!MVar SuccessFlag
mvar,!LogQueue
log_queue),!Int
mod_idx) ->
((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \unmask :: forall a. IO a -> IO a
unmask -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
label_self (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ "worker --make thread"
, "for module"
, String -> String
forall a. Show a => a -> String
show (ModuleName -> String
moduleNameString (ModSummary -> ModuleName
ms_mod_name ModSummary
mod))
, "number"
, Int -> String
forall a. Show a => a -> String
show Int
mod_idx
]
IORef FilesToClean
lcl_files_to_clean <- FilesToClean -> IO (IORef FilesToClean)
forall a. a -> IO (IORef a)
newIORef FilesToClean
emptyFilesToClean
let lcl_dflags :: DynFlags
lcl_dflags = DynFlags
dflags { log_action :: LogAction
log_action = LogQueue -> LogAction
parLogAction LogQueue
log_queue
, filesToClean :: IORef FilesToClean
filesToClean = IORef FilesToClean
lcl_files_to_clean }
Either SomeException SuccessFlag
m_res <- IO SuccessFlag -> IO (Either SomeException SuccessFlag)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO SuccessFlag -> IO (Either SomeException SuccessFlag))
-> IO SuccessFlag -> IO (Either SomeException SuccessFlag)
forall a b. (a -> b) -> a -> b
$ IO SuccessFlag -> IO SuccessFlag
forall a. IO a -> IO a
unmask (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$ DynFlags -> IO SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors DynFlags
lcl_dflags (IO SuccessFlag -> IO SuccessFlag)
-> IO SuccessFlag -> IO SuccessFlag
forall a b. (a -> b) -> a -> b
$
ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> DynFlags
-> Maybe Messager
-> (HscEnv -> IO ())
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one ModSummary
mod Map BuildModule (MVar SuccessFlag, Int)
home_mod_map [[BuildModule]]
comp_graph_loops
DynFlags
lcl_dflags Maybe Messager
mHscMessage HscEnv -> IO ()
cleanup
QSem
par_sem MVar HscEnv
hsc_env_var IORef HomePackageTable
old_hpt_var
(UniqSet ModuleName, UniqSet ModuleName)
stable_mods Int
mod_idx ([SCC ModSummary] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModSummary]
sccs)
SuccessFlag
res <- case Either SomeException SuccessFlag
m_res of
Right flag :: SuccessFlag
flag -> SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
flag
Left exc :: SomeException
exc -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exc Maybe AsyncException -> Maybe AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
/= AsyncException -> Maybe AsyncException
forall a. a -> Maybe a
Just AsyncException
ThreadKilled)
(DynFlags -> SDoc -> IO ()
errorMsg DynFlags
lcl_dflags (String -> SDoc
text (SomeException -> String
forall a. Show a => a -> String
show SomeException
exc)))
SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
MVar SuccessFlag -> SuccessFlag -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar SuccessFlag
mvar SuccessFlag
res
LogQueue
-> Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)
forall a. Maybe a
Nothing
FilesToClean
{ ftcCurrentModule :: FilesToClean -> Set String
ftcCurrentModule = Set String
cm_files
, ftcGhcSession :: FilesToClean -> Set String
ftcGhcSession = Set String
gs_files
} <- IORef FilesToClean -> IO FilesToClean
forall a. IORef a -> IO a
readIORef (DynFlags -> IORef FilesToClean
filesToClean DynFlags
lcl_dflags)
DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
TFL_CurrentModule ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
cm_files
DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
TFL_GhcSession ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
gs_files
; killWorkers :: [ThreadId] -> IO ()
killWorkers = IO () -> IO ()
forall a. IO a -> IO a
uninterruptibleMask_ (IO () -> IO ()) -> ([ThreadId] -> IO ()) -> [ThreadId] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread }
[Maybe ModSummary]
results <- IO [Maybe ModSummary] -> m [Maybe ModSummary]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe ModSummary] -> m [Maybe ModSummary])
-> IO [Maybe ModSummary] -> m [Maybe ModSummary]
forall a b. (a -> b) -> a -> b
$ IO [ThreadId]
-> ([ThreadId] -> IO ())
-> ([ThreadId] -> IO [Maybe ModSummary])
-> IO [Maybe ModSummary]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO [ThreadId]
spawnWorkers [ThreadId] -> IO ()
killWorkers (([ThreadId] -> IO [Maybe ModSummary]) -> IO [Maybe ModSummary])
-> ([ThreadId] -> IO [Maybe ModSummary]) -> IO [Maybe ModSummary]
forall a b. (a -> b) -> a -> b
$ \_ ->
CompilationGraph
-> ((ModSummary, MVar SuccessFlag, LogQueue)
-> IO (Maybe ModSummary))
-> IO [Maybe ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM CompilationGraph
comp_graph (((ModSummary, MVar SuccessFlag, LogQueue)
-> IO (Maybe ModSummary))
-> IO [Maybe ModSummary])
-> ((ModSummary, MVar SuccessFlag, LogQueue)
-> IO (Maybe ModSummary))
-> IO [Maybe ModSummary]
forall a b. (a -> b) -> a -> b
$ \(mod :: ModSummary
mod,mvar :: MVar SuccessFlag
mvar,log_queue :: LogQueue
log_queue) -> do
DynFlags -> LogQueue -> IO ()
printLogs DynFlags
dflags LogQueue
log_queue
SuccessFlag
result <- MVar SuccessFlag -> IO SuccessFlag
forall a. MVar a -> IO a
readMVar MVar SuccessFlag
mvar
if SuccessFlag -> Bool
succeeded SuccessFlag
result then Maybe ModSummary -> IO (Maybe ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
mod) else Maybe ModSummary -> IO (Maybe ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModSummary
forall a. Maybe a
Nothing
let ok_results :: [ModSummary]
ok_results = [ModSummary] -> [ModSummary]
forall a. [a] -> [a]
reverse ([Maybe ModSummary] -> [ModSummary]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ModSummary]
results)
case Maybe [ModSummary]
cycle of
Just mss :: [ModSummary]
mss -> do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
fatalErrorMsg DynFlags
dflags ([ModSummary] -> SDoc
cyclicModuleErr [ModSummary]
mss)
(SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed,[ModSummary]
ok_results)
Nothing -> do
let success_flag :: SuccessFlag
success_flag = Bool -> SuccessFlag
successIf ((Maybe ModSummary -> Bool) -> [Maybe ModSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe ModSummary -> Bool
forall a. Maybe a -> Bool
isJust [Maybe ModSummary]
results)
(SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
success_flag,[ModSummary]
ok_results)
where
writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
writeLogQueue :: LogQueue
-> Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc) -> IO ()
writeLogQueue (LogQueue ref :: IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
ref sem :: MVar ()
sem) msg :: Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)
msg = do
IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
ref (([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)], ()))
-> IO ())
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)], ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \msgs :: [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
msgs -> (Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)
msgMaybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)
-> [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
forall a. a -> [a] -> [a]
:[Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
msgs,())
Bool
_ <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
sem ()
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
parLogAction :: LogQueue -> LogAction
parLogAction :: LogQueue -> LogAction
parLogAction log_queue :: LogQueue
log_queue _dflags :: DynFlags
_dflags !WarnReason
reason !Severity
severity !SrcSpan
srcSpan !PprStyle
style !SDoc
msg = do
LogQueue
-> Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc) -> IO ()
writeLogQueue LogQueue
log_queue ((WarnReason, Severity, SrcSpan, PprStyle, SDoc)
-> Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)
forall a. a -> Maybe a
Just (WarnReason
reason,Severity
severity,SrcSpan
srcSpan,PprStyle
style,SDoc
msg))
printLogs :: DynFlags -> LogQueue -> IO ()
printLogs :: DynFlags -> LogQueue -> IO ()
printLogs !DynFlags
dflags (LogQueue ref :: IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
ref sem :: MVar ()
sem) = IO ()
read_msgs
where read_msgs :: IO ()
read_msgs = do
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
sem
[Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
msgs <- IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)],
[Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]))
-> IO [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
ref (([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)],
[Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]))
-> IO [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)])
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> ([Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)],
[Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]))
-> IO [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
forall a b. (a -> b) -> a -> b
$ \xs :: [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
xs -> ([], [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
-> [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
forall a. [a] -> [a]
reverse [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
xs)
[Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)] -> IO ()
print_loop [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
msgs
print_loop :: [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)] -> IO ()
print_loop [] = IO ()
read_msgs
print_loop (x :: Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)
x:xs :: [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
xs) = case Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)
x of
Just (reason :: WarnReason
reason,severity :: Severity
severity,srcSpan :: SrcSpan
srcSpan,style :: PprStyle
style,msg :: SDoc
msg) -> do
LogAction
putLogMsg DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan PprStyle
style SDoc
msg
[Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)] -> IO ()
print_loop [Maybe (WarnReason, Severity, SrcSpan, PprStyle, SDoc)]
xs
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
parUpsweep_one
:: ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> DynFlags
-> Maybe Messager
-> (HscEnv -> IO ())
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> StableModules
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one :: ModSummary
-> Map BuildModule (MVar SuccessFlag, Int)
-> [[BuildModule]]
-> DynFlags
-> Maybe Messager
-> (HscEnv -> IO ())
-> QSem
-> MVar HscEnv
-> IORef HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> Int
-> Int
-> IO SuccessFlag
parUpsweep_one mod :: ModSummary
mod home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
home_mod_map comp_graph_loops :: [[BuildModule]]
comp_graph_loops lcl_dflags :: DynFlags
lcl_dflags mHscMessage :: Maybe Messager
mHscMessage cleanup :: HscEnv -> IO ()
cleanup par_sem :: QSem
par_sem
hsc_env_var :: MVar HscEnv
hsc_env_var old_hpt_var :: IORef HomePackageTable
old_hpt_var stable_mods :: (UniqSet ModuleName, UniqSet ModuleName)
stable_mods mod_index :: Int
mod_index num_mods :: Int
num_mods = do
let this_build_mod :: BuildModule
this_build_mod = ModSummary -> BuildModule
mkBuildModule ModSummary
mod
let home_imps :: [ModuleName]
home_imps = (Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([Located ModuleName] -> [ModuleName])
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [Located ModuleName]
ms_home_imps ModSummary
mod
let home_src_imps :: [ModuleName]
home_src_imps = (Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc ([Located ModuleName] -> [ModuleName])
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
mod
let textual_deps :: Set BuildModule
textual_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList ([BuildModule] -> Set BuildModule)
-> [BuildModule] -> Set BuildModule
forall a b. (a -> b) -> a -> b
$ (ModuleName -> Module) -> [(ModuleName, IsBoot)] -> [BuildModule]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst (UnitId -> ModuleName -> Module
mkModule (DynFlags -> UnitId
thisPackage DynFlags
lcl_dflags)) ([(ModuleName, IsBoot)] -> [BuildModule])
-> [(ModuleName, IsBoot)] -> [BuildModule]
forall a b. (a -> b) -> a -> b
$
[ModuleName] -> [IsBoot] -> [(ModuleName, IsBoot)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
home_imps (IsBoot -> [IsBoot]
forall a. a -> [a]
repeat IsBoot
NotBoot) [(ModuleName, IsBoot)]
-> [(ModuleName, IsBoot)] -> [(ModuleName, IsBoot)]
forall a. [a] -> [a] -> [a]
++
[ModuleName] -> [IsBoot] -> [(ModuleName, IsBoot)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
home_src_imps (IsBoot -> [IsBoot]
forall a. a -> [a]
repeat IsBoot
IsBoot)
let finish_loop :: Maybe [BuildModule]
finish_loop = [[BuildModule]] -> Maybe [BuildModule]
forall a. [a] -> Maybe a
listToMaybe
[ [BuildModule] -> [BuildModule]
forall a. [a] -> [a]
tail [BuildModule]
loop | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
, [BuildModule] -> BuildModule
forall a. [a] -> a
head [BuildModule]
loop BuildModule -> BuildModule -> Bool
forall a. Eq a => a -> a -> Bool
== BuildModule
this_build_mod ]
let int_loop_deps :: Set BuildModule
int_loop_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList ([BuildModule] -> Set BuildModule)
-> [BuildModule] -> Set BuildModule
forall a b. (a -> b) -> a -> b
$
case Maybe [BuildModule]
finish_loop of
Nothing -> []
Just loop :: [BuildModule]
loop -> (BuildModule -> Bool) -> [BuildModule] -> [BuildModule]
forall a. (a -> Bool) -> [a] -> [a]
filter (BuildModule -> BuildModule -> Bool
forall a. Eq a => a -> a -> Bool
/= BuildModule
this_build_mod) [BuildModule]
loop
let ext_loop_deps :: Set BuildModule
ext_loop_deps = [BuildModule] -> Set BuildModule
forall a. Ord a => [a] -> Set a
Set.fromList
[ [BuildModule] -> BuildModule
forall a. [a] -> a
head [BuildModule]
loop | [BuildModule]
loop <- [[BuildModule]]
comp_graph_loops
, (BuildModule -> Bool) -> [BuildModule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (BuildModule -> Set BuildModule -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildModule
textual_deps) [BuildModule]
loop
, BuildModule
this_build_mod BuildModule -> [BuildModule] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [BuildModule]
loop ]
let all_deps :: Set BuildModule
all_deps = (Set BuildModule -> Set BuildModule -> Set BuildModule)
-> [Set BuildModule] -> Set BuildModule
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Set BuildModule -> Set BuildModule -> Set BuildModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union [Set BuildModule
textual_deps, Set BuildModule
int_loop_deps, Set BuildModule
ext_loop_deps]
let home_deps_with_idx :: [(MVar SuccessFlag, Int)]
home_deps_with_idx =
[ (MVar SuccessFlag, Int)
home_dep | BuildModule
dep <- Set BuildModule -> [BuildModule]
forall a. Set a -> [a]
Set.toList Set BuildModule
all_deps
, Just home_dep :: (MVar SuccessFlag, Int)
home_dep <- [BuildModule
-> Map BuildModule (MVar SuccessFlag, Int)
-> Maybe (MVar SuccessFlag, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BuildModule
dep Map BuildModule (MVar SuccessFlag, Int)
home_mod_map] ]
let home_deps :: [MVar SuccessFlag]
home_deps = ((MVar SuccessFlag, Int) -> MVar SuccessFlag)
-> [(MVar SuccessFlag, Int)] -> [MVar SuccessFlag]
forall a b. (a -> b) -> [a] -> [b]
map (MVar SuccessFlag, Int) -> MVar SuccessFlag
forall a b. (a, b) -> a
fst ([(MVar SuccessFlag, Int)] -> [MVar SuccessFlag])
-> [(MVar SuccessFlag, Int)] -> [MVar SuccessFlag]
forall a b. (a -> b) -> a -> b
$ ((MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering)
-> [(MVar SuccessFlag, Int)] -> [(MVar SuccessFlag, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering)
-> (MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((MVar SuccessFlag, Int) -> Int)
-> (MVar SuccessFlag, Int) -> (MVar SuccessFlag, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (MVar SuccessFlag, Int) -> Int
forall a b. (a, b) -> b
snd)) [(MVar SuccessFlag, Int)]
home_deps_with_idx
Bool
deps_ok <- (MVar SuccessFlag -> IO Bool) -> [MVar SuccessFlag] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM ((SuccessFlag -> Bool) -> IO SuccessFlag -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SuccessFlag -> Bool
succeeded (IO SuccessFlag -> IO Bool)
-> (MVar SuccessFlag -> IO SuccessFlag)
-> MVar SuccessFlag
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar SuccessFlag -> IO SuccessFlag
forall a. MVar a -> IO a
readMVar) [MVar SuccessFlag]
home_deps
if Bool -> Bool
not Bool
deps_ok
then SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
else do
HscEnv
hsc_env <- MVar HscEnv -> IO HscEnv
forall a. MVar a -> IO a
readMVar MVar HscEnv
hsc_env_var
HomePackageTable
old_hpt <- IORef HomePackageTable -> IO HomePackageTable
forall a. IORef a -> IO a
readIORef IORef HomePackageTable
old_hpt_var
let logger :: SourceError -> IO ()
logger err :: SourceError
err = DynFlags -> ErrorMessages -> IO ()
printBagOfErrors DynFlags
lcl_dflags (SourceError -> ErrorMessages
srcErrorMessages SourceError
err)
let withSem :: QSem -> IO c -> IO c
withSem sem :: QSem
sem = IO () -> IO () -> IO c -> IO c
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (QSem -> IO ()
waitQSem QSem
sem) (QSem -> IO ()
signalQSem QSem
sem)
Maybe HomeModInfo
mb_mod_info <- QSem -> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall c. QSem -> IO c -> IO c
withSem QSem
par_sem (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$
(SourceError -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError (\err :: SourceError
err -> do SourceError -> IO ()
logger SourceError
err; Maybe HomeModInfo -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HomeModInfo
forall a. Maybe a
Nothing) (IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo))
-> IO (Maybe HomeModInfo) -> IO (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
let lcl_mod :: ModSummary
lcl_mod = ModSummary -> ModSummary
localize_mod ModSummary
mod
let lcl_hsc_env :: HscEnv
lcl_hsc_env = HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env
IORef (NameEnv TyThing)
type_env_var <- IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing)))
-> IO (IORef (NameEnv TyThing)) -> IO (IORef (NameEnv TyThing))
forall a b. (a -> b) -> a -> b
$ NameEnv TyThing -> IO (IORef (NameEnv TyThing))
forall a. a -> IO (IORef a)
newIORef NameEnv TyThing
forall a. NameEnv a
emptyNameEnv
let lcl_hsc_env' :: HscEnv
lcl_hsc_env' = HscEnv
lcl_hsc_env { hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var =
(Module, IORef (NameEnv TyThing))
-> Maybe (Module, IORef (NameEnv TyThing))
forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
lcl_mod, IORef (NameEnv TyThing)
type_env_var) }
HscEnv
lcl_hsc_env'' <- case Maybe [BuildModule]
finish_loop of
Nothing -> HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
lcl_hsc_env'
Just loop :: [BuildModule]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
lcl_hsc_env' ([ModuleName] -> IO HscEnv) -> [ModuleName] -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
(ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= Module -> ModuleName
moduleName (BuildModule -> Module
forall a b. (a, b) -> a
fst BuildModule
this_build_mod)) ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
(BuildModule -> ModuleName) -> [BuildModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
moduleName (Module -> ModuleName)
-> (BuildModule -> Module) -> BuildModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildModule -> Module
forall a b. (a, b) -> a
fst) [BuildModule]
loop
HomeModInfo
mod_info <- HscEnv
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
lcl_hsc_env'' Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName, UniqSet ModuleName)
stable_mods
ModSummary
lcl_mod Int
mod_index Int
num_mods
Maybe HomeModInfo -> IO (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
mod_info)
case Maybe HomeModInfo
mb_mod_info of
Nothing -> SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Failed
Just mod_info :: HomeModInfo
mod_info -> do
let this_mod :: ModuleName
this_mod = ModSummary -> ModuleName
ms_mod_name ModSummary
mod
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ModSummary -> Bool
isBootSummary ModSummary
mod) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IORef HomePackageTable
-> (HomePackageTable -> (HomePackageTable, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef HomePackageTable
old_hpt_var ((HomePackageTable -> (HomePackageTable, ())) -> IO ())
-> (HomePackageTable -> (HomePackageTable, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \old_hpt :: HomePackageTable
old_hpt ->
(HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt HomePackageTable
old_hpt ModuleName
this_mod, ())
HscEnv
lcl_hsc_env' <- MVar HscEnv -> (HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar HscEnv
hsc_env_var ((HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv)
-> (HscEnv -> IO (HscEnv, HscEnv)) -> IO HscEnv
forall a b. (a -> b) -> a -> b
$ \hsc_env :: HscEnv
hsc_env -> do
let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env
{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
ModuleName
this_mod HomeModInfo
mod_info }
HscEnv
hsc_env'' <- case Maybe [BuildModule]
finish_loop of
Nothing -> HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env'
Just loop :: [BuildModule]
loop -> DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop DynFlags
lcl_dflags HscEnv
hsc_env' ([ModuleName] -> IO HscEnv) -> [ModuleName] -> IO HscEnv
forall a b. (a -> b) -> a -> b
$
(BuildModule -> ModuleName) -> [BuildModule] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
moduleName (Module -> ModuleName)
-> (BuildModule -> Module) -> BuildModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildModule -> Module
forall a b. (a, b) -> a
fst) [BuildModule]
loop
(HscEnv, HscEnv) -> IO (HscEnv, HscEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
hsc_env'', HscEnv -> HscEnv
localize_hsc_env HscEnv
hsc_env'')
HscEnv -> IO ()
cleanup HscEnv
lcl_hsc_env'
SuccessFlag -> IO SuccessFlag
forall (m :: * -> *) a. Monad m => a -> m a
return SuccessFlag
Succeeded
where
localize_mod :: ModSummary -> ModSummary
localize_mod mod :: ModSummary
mod
= ModSummary
mod { ms_hspp_opts :: DynFlags
ms_hspp_opts = (ModSummary -> DynFlags
ms_hspp_opts ModSummary
mod)
{ log_action :: LogAction
log_action = DynFlags -> LogAction
log_action DynFlags
lcl_dflags
, filesToClean :: IORef FilesToClean
filesToClean = DynFlags -> IORef FilesToClean
filesToClean DynFlags
lcl_dflags } }
localize_hsc_env :: HscEnv -> HscEnv
localize_hsc_env hsc_env :: HscEnv
hsc_env
= HscEnv
hsc_env { hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
{ log_action :: LogAction
log_action = DynFlags -> LogAction
log_action DynFlags
lcl_dflags
, filesToClean :: IORef FilesToClean
filesToClean = DynFlags -> IORef FilesToClean
filesToClean DynFlags
lcl_dflags } }
upsweep
:: GhcMonad m
=> Maybe Messager
-> HomePackageTable
-> StableModules
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag,
[ModSummary])
upsweep :: Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> (HscEnv -> IO ())
-> [SCC ModSummary]
-> m (SuccessFlag, [ModSummary])
upsweep mHscMessage :: Maybe Messager
mHscMessage old_hpt :: HomePackageTable
old_hpt stable_mods :: (UniqSet ModuleName, UniqSet ModuleName)
stable_mods cleanup :: HscEnv -> IO ()
cleanup sccs :: [SCC ModSummary]
sccs = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
(res :: SuccessFlag
res, done :: ModuleGraph
done) <- HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt ModuleGraph
emptyMG [SCC ModSummary]
sccs 1 ([SCC ModSummary] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SCC ModSummary]
sccs)
(DynFlags -> [UnitId]
unitIdsToCheck DynFlags
dflags) UniqSet ModuleName
forall a. UniqSet a
done_holes
(SuccessFlag, [ModSummary]) -> m (SuccessFlag, [ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
res, [ModSummary] -> [ModSummary]
forall a. [a] -> [a]
reverse ([ModSummary] -> [ModSummary]) -> [ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
done)
where
done_holes :: UniqSet a
done_holes = UniqSet a
forall a. UniqSet a
emptyUniqSet
upsweep'
:: GhcMonad m
=> HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' :: HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' _old_hpt :: HomePackageTable
_old_hpt done :: ModuleGraph
done
[] _ _ uids_to_check :: [UnitId]
uids_to_check _
= do HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Hsc () -> IO ()) -> Hsc () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> m ()) -> Hsc () -> m ()
forall a b. (a -> b) -> a -> b
$ (UnitId -> Hsc ()) -> [UnitId] -> Hsc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO (Messages, Maybe ()) -> Hsc ()
forall a. IO (Messages, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages, Maybe ()) -> Hsc ())
-> (UnitId -> IO (Messages, Maybe ())) -> UnitId -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitId -> IO (Messages, Maybe ())
tcRnCheckUnitId HscEnv
hsc_env) [UnitId]
uids_to_check
(SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Succeeded, ModuleGraph
done)
upsweep' _old_hpt :: HomePackageTable
_old_hpt done :: ModuleGraph
done
(CyclicSCC ms :: [ModSummary]
ms:_) _ _ _ _
= do DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
fatalErrorMsg DynFlags
dflags ([ModSummary] -> SDoc
cyclicModuleErr [ModSummary]
ms)
(SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done)
upsweep' old_hpt :: HomePackageTable
old_hpt done :: ModuleGraph
done
(AcyclicSCC mod :: ModSummary
mod:mods :: [SCC ModSummary]
mods) mod_index :: Int
mod_index nmods :: Int
nmods uids_to_check :: [UnitId]
uids_to_check done_holes :: UniqSet ModuleName
done_holes
= do
let logger :: p -> Maybe SourceError -> m ()
logger _mod :: p
_mod = Maybe SourceError -> m ()
WarnErrLogger
defaultWarnErrLogger
HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
let (ready_uids :: [UnitId]
ready_uids, uids_to_check' :: [UnitId]
uids_to_check')
= (UnitId -> Bool) -> [UnitId] -> ([UnitId], [UnitId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\uid :: UnitId
uid -> UniqDSet ModuleName -> Bool
forall a. UniqDSet a -> Bool
isEmptyUniqDSet
(UnitId -> UniqDSet ModuleName
unitIdFreeHoles UnitId
uid UniqDSet ModuleName -> UniqSet ModuleName -> UniqDSet ModuleName
forall a b. UniqDSet a -> UniqSet b -> UniqDSet a
`uniqDSetMinusUniqSet` UniqSet ModuleName
done_holes))
[UnitId]
uids_to_check
done_holes' :: UniqSet ModuleName
done_holes'
| ModSummary -> HscSource
ms_hsc_src ModSummary
mod HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
= UniqSet ModuleName -> ModuleName -> UniqSet ModuleName
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet ModuleName
done_holes (ModSummary -> ModuleName
ms_mod_name ModSummary
mod)
| Bool
otherwise = UniqSet ModuleName
done_holes
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Hsc () -> IO ()) -> Hsc () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Hsc () -> IO ()
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc () -> m ()) -> Hsc () -> m ()
forall a b. (a -> b) -> a -> b
$ (UnitId -> Hsc ()) -> [UnitId] -> Hsc ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO (Messages, Maybe ()) -> Hsc ()
forall a. IO (Messages, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages, Maybe ()) -> Hsc ())
-> (UnitId -> IO (Messages, Maybe ())) -> UnitId -> Hsc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> UnitId -> IO (Messages, Maybe ())
tcRnCheckUnitId HscEnv
hsc_env) [UnitId]
ready_uids
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> IO ()
cleanup HscEnv
hsc_env)
IORef (NameEnv TyThing)
type_env_var <- IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing)))
-> IO (IORef (NameEnv TyThing)) -> m (IORef (NameEnv TyThing))
forall a b. (a -> b) -> a -> b
$ NameEnv TyThing -> IO (IORef (NameEnv TyThing))
forall a. a -> IO (IORef a)
newIORef NameEnv TyThing
forall a. NameEnv a
emptyNameEnv
let hsc_env1 :: HscEnv
hsc_env1 = HscEnv
hsc_env { hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var =
(Module, IORef (NameEnv TyThing))
-> Maybe (Module, IORef (NameEnv TyThing))
forall a. a -> Maybe a
Just (ModSummary -> Module
ms_mod ModSummary
mod, IORef (NameEnv TyThing)
type_env_var) }
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env1
HscEnv
hsc_env2 <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env1 ModSummary
mod ModuleGraph
done
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env2
Maybe HomeModInfo
mb_mod_info
<- (SourceError -> m (Maybe HomeModInfo))
-> m (Maybe HomeModInfo) -> m (Maybe HomeModInfo)
forall (m :: * -> *) a.
ExceptionMonad m =>
(SourceError -> m a) -> m a -> m a
handleSourceError
(\err :: SourceError
err -> do ModSummary -> Maybe SourceError -> m ()
forall (m :: * -> *) p.
GhcMonad m =>
p -> Maybe SourceError -> m ()
logger ModSummary
mod (SourceError -> Maybe SourceError
forall a. a -> Maybe a
Just SourceError
err); Maybe HomeModInfo -> m (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HomeModInfo
forall a. Maybe a
Nothing) (m (Maybe HomeModInfo) -> m (Maybe HomeModInfo))
-> m (Maybe HomeModInfo) -> m (Maybe HomeModInfo)
forall a b. (a -> b) -> a -> b
$ do
HomeModInfo
mod_info <- IO HomeModInfo -> m HomeModInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HomeModInfo -> m HomeModInfo)
-> IO HomeModInfo -> m HomeModInfo
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod HscEnv
hsc_env2 Maybe Messager
mHscMessage HomePackageTable
old_hpt (UniqSet ModuleName, UniqSet ModuleName)
stable_mods
ModSummary
mod Int
mod_index Int
nmods
ModSummary -> Maybe SourceError -> m ()
forall (m :: * -> *) p.
GhcMonad m =>
p -> Maybe SourceError -> m ()
logger ModSummary
mod Maybe SourceError
forall a. Maybe a
Nothing
Maybe HomeModInfo -> m (Maybe HomeModInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (HomeModInfo -> Maybe HomeModInfo
forall a. a -> Maybe a
Just HomeModInfo
mod_info)
case Maybe HomeModInfo
mb_mod_info of
Nothing -> (SuccessFlag, ModuleGraph) -> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (SuccessFlag
Failed, ModuleGraph
done)
Just mod_info :: HomeModInfo
mod_info -> do
let this_mod :: ModuleName
this_mod = ModSummary -> ModuleName
ms_mod_name ModSummary
mod
hpt1 :: HomePackageTable
hpt1 = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env2) ModuleName
this_mod HomeModInfo
mod_info
hsc_env3 :: HscEnv
hsc_env3 = HscEnv
hsc_env2 { hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
hpt1, hsc_type_env_var :: Maybe (Module, IORef (NameEnv TyThing))
hsc_type_env_var = Maybe (Module, IORef (NameEnv TyThing))
forall a. Maybe a
Nothing }
old_hpt1 :: HomePackageTable
old_hpt1 | ModSummary -> Bool
isBootSummary ModSummary
mod = HomePackageTable
old_hpt
| Bool
otherwise = HomePackageTable -> ModuleName -> HomePackageTable
delFromHpt HomePackageTable
old_hpt ModuleName
this_mod
done' :: ModuleGraph
done' = ModuleGraph -> ModSummary -> ModuleGraph
extendMG ModuleGraph
done ModSummary
mod
HscEnv
hsc_env4 <- IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop HscEnv
hsc_env3 ModSummary
mod ModuleGraph
done'
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env4
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> HscTarget
hscTarget (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env4) HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env4
[ SptEntry
spt
| Just linkable :: Linkable
linkable <- Maybe Linkable -> [Maybe Linkable]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Linkable -> [Maybe Linkable])
-> Maybe Linkable -> [Maybe Linkable]
forall a b. (a -> b) -> a -> b
$ HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
mod_info
, Unlinked
unlinked <- Linkable -> [Unlinked]
linkableUnlinked Linkable
linkable
, BCOs _ spts :: [SptEntry]
spts <- Unlinked -> [Unlinked]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Unlinked
unlinked
, SptEntry
spt <- [SptEntry]
spts
]
HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
forall (m :: * -> *).
GhcMonad m =>
HomePackageTable
-> ModuleGraph
-> [SCC ModSummary]
-> Int
-> Int
-> [UnitId]
-> UniqSet ModuleName
-> m (SuccessFlag, ModuleGraph)
upsweep' HomePackageTable
old_hpt1 ModuleGraph
done' [SCC ModSummary]
mods (Int
mod_indexInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int
nmods [UnitId]
uids_to_check' UniqSet ModuleName
done_holes'
unitIdsToCheck :: DynFlags -> [UnitId]
unitIdsToCheck :: DynFlags -> [UnitId]
unitIdsToCheck dflags :: DynFlags
dflags =
[UnitId] -> [UnitId]
forall a. Ord a => [a] -> [a]
nubSort ([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ (UnitId -> [UnitId]) -> [UnitId] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitId -> [UnitId]
goUnitId (PackageState -> [UnitId]
explicitPackages (DynFlags -> PackageState
pkgState DynFlags
dflags))
where
goUnitId :: UnitId -> [UnitId]
goUnitId uid :: UnitId
uid =
case UnitId -> (InstalledUnitId, Maybe IndefUnitId)
splitUnitIdInsts UnitId
uid of
(_, Just indef :: IndefUnitId
indef) ->
let insts :: [(ModuleName, Module)]
insts = IndefUnitId -> [(ModuleName, Module)]
indefUnitIdInsts IndefUnitId
indef
in UnitId
uid UnitId -> [UnitId] -> [UnitId]
forall a. a -> [a] -> [a]
: ((ModuleName, Module) -> [UnitId])
-> [(ModuleName, Module)] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (UnitId -> [UnitId]
goUnitId (UnitId -> [UnitId])
-> ((ModuleName, Module) -> UnitId)
-> (ModuleName, Module)
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> UnitId
moduleUnitId (Module -> UnitId)
-> ((ModuleName, Module) -> Module)
-> (ModuleName, Module)
-> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Module) -> Module
forall a b. (a, b) -> b
snd) [(ModuleName, Module)]
insts
_ -> []
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate dflags :: DynFlags
dflags location :: ModLocation
location
| DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags
= String -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> String
ml_hi_file ModLocation
location)
| Bool
otherwise
= Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> StableModules
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod :: HscEnv
-> Maybe Messager
-> HomePackageTable
-> (UniqSet ModuleName, UniqSet ModuleName)
-> ModSummary
-> Int
-> Int
-> IO HomeModInfo
upsweep_mod hsc_env :: HscEnv
hsc_env mHscMessage :: Maybe Messager
mHscMessage old_hpt :: HomePackageTable
old_hpt (stable_obj :: UniqSet ModuleName
stable_obj, stable_bco :: UniqSet ModuleName
stable_bco) summary :: ModSummary
summary mod_index :: Int
mod_index nmods :: Int
nmods
= let
this_mod_name :: ModuleName
this_mod_name = ModSummary -> ModuleName
ms_mod_name ModSummary
summary
this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
summary
mb_obj_date :: Maybe UTCTime
mb_obj_date = ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
summary
mb_if_date :: Maybe UTCTime
mb_if_date = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
summary
obj_fn :: String
obj_fn = ModLocation -> String
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
hs_date :: UTCTime
hs_date = ModSummary -> UTCTime
ms_hs_date ModSummary
summary
is_stable_obj :: Bool
is_stable_obj = ModuleName
this_mod_name ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_obj
is_stable_bco :: Bool
is_stable_bco = ModuleName
this_mod_name ModuleName -> UniqSet ModuleName -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet ModuleName
stable_bco
old_hmi :: Maybe HomeModInfo
old_hmi = HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt ModuleName
this_mod_name
dflags :: DynFlags
dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
summary
prevailing_target :: HscTarget
prevailing_target = DynFlags -> HscTarget
hscTarget (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
local_target :: HscTarget
local_target = DynFlags -> HscTarget
hscTarget DynFlags
dflags
target :: HscTarget
target = if HscTarget
prevailing_target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
local_target
Bool -> Bool -> Bool
&& (Bool -> Bool
not (HscTarget -> Bool
isObjectTarget HscTarget
prevailing_target)
Bool -> Bool -> Bool
|| Bool -> Bool
not (HscTarget -> Bool
isObjectTarget HscTarget
local_target))
Bool -> Bool -> Bool
&& Bool -> Bool
not (HscTarget
prevailing_target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing)
Bool -> Bool -> Bool
&& Bool -> Bool
not (HscTarget
prevailing_target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted)
then HscTarget
prevailing_target
else HscTarget
local_target
summary' :: ModSummary
summary' = ModSummary
summary{ ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dflags { hscTarget :: HscTarget
hscTarget = HscTarget
target } }
mb_old_iface :: Maybe ModIface
mb_old_iface
= case Maybe HomeModInfo
old_hmi of
Nothing -> Maybe ModIface
forall a. Maybe a
Nothing
Just hm_info :: HomeModInfo
hm_info | ModSummary -> Bool
isBootSummary ModSummary
summary -> ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface
| Bool -> Bool
not (ModIface -> Bool
mi_boot ModIface
iface) -> ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface
| Bool
otherwise -> Maybe ModIface
forall a. Maybe a
Nothing
where
iface :: ModIface
iface = HomeModInfo -> ModIface
hm_iface HomeModInfo
hm_info
compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it mb_linkable :: Maybe Linkable
mb_linkable src_modified :: SourceModified
src_modified =
Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
Maybe ModIface
mb_old_iface Maybe Linkable
mb_linkable SourceModified
src_modified
compile_it_discard_iface :: Maybe Linkable -> SourceModified
-> IO HomeModInfo
compile_it_discard_iface :: Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it_discard_iface mb_linkable :: Maybe Linkable
mb_linkable src_modified :: SourceModified
src_modified =
Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> Int
-> Int
-> Maybe ModIface
-> Maybe Linkable
-> SourceModified
-> IO HomeModInfo
compileOne' Maybe TcGblEnv
forall a. Maybe a
Nothing Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
summary' Int
mod_index Int
nmods
Maybe ModIface
forall a. Maybe a
Nothing Maybe Linkable
mb_linkable SourceModified
src_modified
is_fake_linkable :: Bool
is_fake_linkable
| Just hmi :: HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi, Just l :: Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi =
[Unlinked] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Linkable -> [Unlinked]
linkableUnlinked Linkable
l)
| Bool
otherwise =
Bool
False
implies :: Bool -> Bool -> Bool
implies False _ = Bool
True
implies True x :: Bool
x = Bool
x
in
case () of
_
| Bool
is_stable_obj, Just hmi :: HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 5
(String -> SDoc
text "skipping stable obj mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
| Bool
is_stable_obj, Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe HomeModInfo
old_hmi -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 5
(String -> SDoc
text "compiling stable on-disk mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Linkable
linkable <- IO Linkable -> IO Linkable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Linkable -> IO Linkable) -> IO Linkable -> IO Linkable
forall a b. (a -> b) -> a -> b
$ Module -> String -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod String
obj_fn
(String -> Maybe UTCTime -> UTCTime
forall a. HasCallStack => String -> Maybe a -> a
expectJust "upsweep1" Maybe UTCTime
mb_obj_date)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodifiedAndStable
| Bool -> Bool
not (HscTarget -> Bool
isObjectTarget HscTarget
target), Bool
is_stable_bco,
(HscTarget
target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
HscNothing) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable ->
ASSERT(isJust old_hmi)
let Just hmi :: HomeModInfo
hmi = Maybe HomeModInfo
old_hmi in do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 5
(String -> SDoc
text "skipping stable BCO mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
HomeModInfo -> IO HomeModInfo
forall (m :: * -> *) a. Monad m => a -> m a
return HomeModInfo
hmi
| Bool -> Bool
not (HscTarget -> Bool
isObjectTarget HscTarget
target),
Just hmi :: HomeModInfo
hmi <- Maybe HomeModInfo
old_hmi,
Just l :: Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
l),
(HscTarget
target HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HscTarget
HscNothing) Bool -> Bool -> Bool
`implies` Bool -> Bool
not Bool
is_fake_linkable,
Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= ModSummary -> UTCTime
ms_hs_date ModSummary
summary -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 5
(String -> SDoc
text "compiling non-stable BCO mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
| HscTarget -> Bool
isObjectTarget HscTarget
target,
Just obj_date :: UTCTime
obj_date <- Maybe UTCTime
mb_obj_date,
UTCTime
obj_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
hs_date -> do
case Maybe HomeModInfo
old_hmi of
Just hmi :: HomeModInfo
hmi
| Just l :: Linkable
l <- HomeModInfo -> Maybe Linkable
hm_linkable HomeModInfo
hmi,
Linkable -> Bool
isObjectLinkable Linkable
l Bool -> Bool -> Bool
&& Linkable -> UTCTime
linkableTime Linkable
l UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
obj_date -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 5
(String -> SDoc
text "compiling mod with new on-disk obj:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
l) SourceModified
SourceUnmodified
_otherwise :: Maybe HomeModInfo
_otherwise -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 5
(String -> SDoc
text "compiling mod with new on-disk obj2:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Linkable
linkable <- IO Linkable -> IO Linkable
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Linkable -> IO Linkable) -> IO Linkable -> IO Linkable
forall a b. (a -> b) -> a -> b
$ Module -> String -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod String
obj_fn UTCTime
obj_date
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it_discard_iface (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
linkable) SourceModified
SourceUnmodified
| DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags,
Just if_date :: UTCTime
if_date <- Maybe UTCTime
mb_if_date,
UTCTime
if_date UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
hs_date -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 5
(String -> SDoc
text "skipping tc'd mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it Maybe Linkable
forall a. Maybe a
Nothing SourceModified
SourceUnmodified
_otherwise :: ()
_otherwise -> do
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) 5
(String -> SDoc
text "compiling mod:" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
this_mod_name)
Maybe Linkable -> SourceModified -> IO HomeModInfo
compile_it Maybe Linkable
forall a. Maybe a
Nothing SourceModified
SourceModified
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs keep_these :: [ModuleName]
keep_these hpt :: HomePackageTable
hpt
= [(ModuleName, HomeModInfo)] -> HomePackageTable
listToHpt [ (ModuleName
mod, String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => String -> Maybe a -> a
expectJust "retain" Maybe HomeModInfo
mb_mod_info)
| ModuleName
mod <- [ModuleName]
keep_these
, let mb_mod_info :: Maybe HomeModInfo
mb_mod_info = HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
hpt ModuleName
mod
, Maybe HomeModInfo -> Bool
forall a. Maybe a -> Bool
isJust Maybe HomeModInfo
mb_mod_info ]
reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
reTypecheckLoop hsc_env :: HscEnv
hsc_env ms :: ModSummary
ms graph :: ModuleGraph
graph
| Just loop :: [ModSummary]
loop <- ModSummary
-> [ModSummary] -> (Module -> Bool) -> Maybe [ModSummary]
getModLoop ModSummary
ms [ModSummary]
mss Module -> Bool
appearsAsBoot
, let non_boot :: [ModSummary]
non_boot = (ModSummary -> Bool) -> [ModSummary] -> [ModSummary]
forall a. (a -> Bool) -> [a] -> [a]
filter (\l :: ModSummary
l -> Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
l Bool -> Bool -> Bool
&&
ModSummary -> Module
ms_mod ModSummary
l Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> Module
ms_mod ModSummary
ms)) [ModSummary]
loop
= DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) HscEnv
hsc_env ((ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
non_boot)
| Bool
otherwise
= HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
where
mss :: [ModSummary]
mss = ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
graph
appearsAsBoot :: Module -> Bool
appearsAsBoot = (Module -> ModuleSet -> Bool
`elemModuleSet` ModuleGraph -> ModuleSet
mgBootModules ModuleGraph
graph)
getModLoop
:: ModSummary
-> [ModSummary]
-> (Module -> Bool)
-> Maybe [ModSummary]
getModLoop :: ModSummary
-> [ModSummary] -> (Module -> Bool) -> Maybe [ModSummary]
getModLoop ms :: ModSummary
ms graph :: [ModSummary]
graph appearsAsBoot :: Module -> Bool
appearsAsBoot
| Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
ms)
, Module -> Bool
appearsAsBoot Module
this_mod
, let mss :: [ModSummary]
mss = ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards (ModSummary -> ModuleName
ms_mod_name ModSummary
ms) [ModSummary]
graph
= [ModSummary] -> Maybe [ModSummary]
forall a. a -> Maybe a
Just [ModSummary]
mss
| Bool
otherwise
= Maybe [ModSummary]
forall a. Maybe a
Nothing
where
this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
ms
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
typecheckLoop dflags :: DynFlags
dflags hsc_env :: HscEnv
hsc_env mods :: [ModuleName]
mods = do
DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "Re-typechecking loop: " SDoc -> SDoc -> SDoc
<> [ModuleName] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleName]
mods
HomePackageTable
new_hpt <-
(HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable
forall a. (a -> IO a) -> IO a
fixIO ((HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable)
-> (HomePackageTable -> IO HomePackageTable) -> IO HomePackageTable
forall a b. (a -> b) -> a -> b
$ \new_hpt :: HomePackageTable
new_hpt -> do
let new_hsc_env :: HscEnv
new_hsc_env = HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
[ModDetails]
mds <- SDoc -> HscEnv -> IfG [ModDetails] -> IO [ModDetails]
forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (String -> SDoc
text "typecheckLoop") HscEnv
new_hsc_env (IfG [ModDetails] -> IO [ModDetails])
-> IfG [ModDetails] -> IO [ModDetails]
forall a b. (a -> b) -> a -> b
$
(HomeModInfo -> IOEnv (Env IfGblEnv ()) ModDetails)
-> [HomeModInfo] -> IfG [ModDetails]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModIface -> 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_hpt :: HomePackageTable
new_hpt = HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
addListToHpt HomePackageTable
old_hpt
([ModuleName] -> [HomeModInfo] -> [(ModuleName, HomeModInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
mods [ HomeModInfo
hmi{ hm_details :: ModDetails
hm_details = ModDetails
details }
| (hmi :: HomeModInfo
hmi,details :: ModDetails
details) <- [HomeModInfo] -> [ModDetails] -> [(HomeModInfo, ModDetails)]
forall a b. [a] -> [b] -> [(a, b)]
zip [HomeModInfo]
hmis [ModDetails]
mds ])
HomePackageTable -> IO HomePackageTable
forall (m :: * -> *) a. Monad m => a -> m a
return HomePackageTable
new_hpt
HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env{ hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
new_hpt }
where
old_hpt :: HomePackageTable
old_hpt = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
hmis :: [HomeModInfo]
hmis = (ModuleName -> HomeModInfo) -> [ModuleName] -> [HomeModInfo]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe HomeModInfo -> HomeModInfo
forall a. HasCallStack => String -> Maybe a -> a
expectJust "typecheckLoop" (Maybe HomeModInfo -> HomeModInfo)
-> (ModuleName -> Maybe HomeModInfo) -> ModuleName -> HomeModInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomePackageTable -> ModuleName -> Maybe HomeModInfo
lookupHpt HomePackageTable
old_hpt) [ModuleName]
mods
reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
reachableBackwards mod :: ModuleName
mod summaries :: [ModSummary]
summaries
= [ Node Int ModSummary -> ModSummary
forall key payload. Node key payload -> payload
node_payload Node Int ModSummary
node | Node Int ModSummary
node <- Graph (Node Int ModSummary)
-> Node Int ModSummary -> [Node Int ModSummary]
forall node. Graph node -> node -> [node]
reachableG (Graph (Node Int ModSummary) -> Graph (Node Int ModSummary)
forall node. Graph node -> Graph node
transposeG Graph (Node Int ModSummary)
graph) Node Int ModSummary
root ]
where
(graph :: Graph (Node Int ModSummary)
graph, lookup_node :: HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node) = Bool
-> [ModSummary]
-> (Graph (Node Int ModSummary),
HscSource -> ModuleName -> Maybe (Node Int ModSummary))
moduleGraphNodes Bool
False [ModSummary]
summaries
root :: Node Int ModSummary
root = String -> Maybe (Node Int ModSummary) -> Node Int ModSummary
forall a. HasCallStack => String -> Maybe a -> a
expectJust "reachableBackwards" (HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node HscSource
HsBootFile ModuleName
mod)
topSortModuleGraph
:: Bool
-> ModuleGraph
-> Maybe ModuleName
-> [SCC ModSummary]
topSortModuleGraph :: Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph drop_hs_boot_nodes :: Bool
drop_hs_boot_nodes module_graph :: ModuleGraph
module_graph mb_root_mod :: Maybe ModuleName
mb_root_mod
= (SCC (Node Int ModSummary) -> SCC ModSummary)
-> [SCC (Node Int ModSummary)] -> [SCC ModSummary]
forall a b. (a -> b) -> [a] -> [b]
map ((Node Int ModSummary -> ModSummary)
-> SCC (Node Int ModSummary) -> SCC ModSummary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node Int ModSummary -> ModSummary
summaryNodeSummary) ([SCC (Node Int ModSummary)] -> [SCC ModSummary])
-> [SCC (Node Int ModSummary)] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$ Graph (Node Int ModSummary) -> [SCC (Node Int ModSummary)]
forall node. Graph node -> [SCC node]
stronglyConnCompG Graph (Node Int ModSummary)
initial_graph
where
summaries :: [ModSummary]
summaries = ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
module_graph
(graph :: Graph (Node Int ModSummary)
graph, lookup_node :: HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node) =
Bool
-> [ModSummary]
-> (Graph (Node Int ModSummary),
HscSource -> ModuleName -> Maybe (Node Int ModSummary))
moduleGraphNodes Bool
drop_hs_boot_nodes ([ModSummary] -> [ModSummary]
forall a. [a] -> [a]
reverse [ModSummary]
summaries)
initial_graph :: Graph (Node Int ModSummary)
initial_graph = case Maybe ModuleName
mb_root_mod of
Nothing -> Graph (Node Int ModSummary)
graph
Just root_mod :: ModuleName
root_mod ->
let root :: Node Int ModSummary
root | Just node :: Node Int ModSummary
node <- HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node HscSource
HsSrcFile ModuleName
root_mod
, Graph (Node Int ModSummary)
graph Graph (Node Int ModSummary) -> Node Int ModSummary -> Bool
forall node. Graph node -> node -> Bool
`hasVertexG` Node Int ModSummary
node
= Node Int ModSummary
node
| Bool
otherwise
= GhcException -> Node Int ModSummary
forall a. GhcException -> a
throwGhcException (String -> GhcException
ProgramError "module does not exist")
in [Node Int ModSummary] -> Graph (Node Int ModSummary)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq (Node Int ModSummary
-> [Node Int ModSummary] -> [Node Int ModSummary]
forall a b. a -> b -> b
seq Node Int ModSummary
root (Graph (Node Int ModSummary)
-> Node Int ModSummary -> [Node Int ModSummary]
forall node. Graph node -> node -> [node]
reachableG Graph (Node Int ModSummary)
graph Node Int ModSummary
root))
type SummaryNode = Node Int ModSummary
summaryNodeKey :: SummaryNode -> Int
summaryNodeKey :: Node Int ModSummary -> Int
summaryNodeKey = Node Int ModSummary -> Int
forall key payload. Node key payload -> key
node_key
summaryNodeSummary :: SummaryNode -> ModSummary
summaryNodeSummary :: Node Int ModSummary -> ModSummary
summaryNodeSummary = Node Int ModSummary -> ModSummary
forall key payload. Node key payload -> payload
node_payload
moduleGraphNodes :: Bool -> [ModSummary]
-> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
moduleGraphNodes :: Bool
-> [ModSummary]
-> (Graph (Node Int ModSummary),
HscSource -> ModuleName -> Maybe (Node Int ModSummary))
moduleGraphNodes drop_hs_boot_nodes :: Bool
drop_hs_boot_nodes summaries :: [ModSummary]
summaries =
([Node Int ModSummary] -> Graph (Node Int ModSummary)
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [Node Int ModSummary]
nodes, HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node)
where
numbered_summaries :: [(ModSummary, Int)]
numbered_summaries = [ModSummary] -> [Int] -> [(ModSummary, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModSummary]
summaries [1..]
lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
lookup_node :: HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node hs_src :: HscSource
hs_src mod :: ModuleName
mod = (ModuleName, IsBoot)
-> Map (ModuleName, IsBoot) (Node Int ModSummary)
-> Maybe (Node Int ModSummary)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModuleName
mod, HscSource -> IsBoot
hscSourceToIsBoot HscSource
hs_src) Map (ModuleName, IsBoot) (Node Int ModSummary)
node_map
lookup_key :: HscSource -> ModuleName -> Maybe Int
lookup_key :: HscSource -> ModuleName -> Maybe Int
lookup_key hs_src :: HscSource
hs_src mod :: ModuleName
mod = (Node Int ModSummary -> Int)
-> Maybe (Node Int ModSummary) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node Int ModSummary -> Int
summaryNodeKey (HscSource -> ModuleName -> Maybe (Node Int ModSummary)
lookup_node HscSource
hs_src ModuleName
mod)
node_map :: NodeMap SummaryNode
node_map :: Map (ModuleName, IsBoot) (Node Int ModSummary)
node_map = [((ModuleName, IsBoot), Node Int ModSummary)]
-> Map (ModuleName, IsBoot) (Node Int ModSummary)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ((Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
s),
HscSource -> IsBoot
hscSourceToIsBoot (ModSummary -> HscSource
ms_hsc_src ModSummary
s)), Node Int ModSummary
node)
| Node Int ModSummary
node <- [Node Int ModSummary]
nodes
, let s :: ModSummary
s = Node Int ModSummary -> ModSummary
summaryNodeSummary Node Int ModSummary
node ]
nodes :: [SummaryNode]
nodes :: [Node Int ModSummary]
nodes = [ ModSummary -> Int -> [Int] -> Node Int ModSummary
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ModSummary
s Int
key [Int]
out_keys
| (s :: ModSummary
s, key :: Int
key) <- [(ModSummary, Int)]
numbered_summaries
, Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
s Bool -> Bool -> Bool
&& Bool
drop_hs_boot_nodes)
, let out_keys :: [Int]
out_keys = HscSource -> [ModuleName] -> [Int]
out_edge_keys HscSource
hs_boot_key ((Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
s)) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
HscSource -> [ModuleName] -> [Int]
out_edge_keys HscSource
HsSrcFile ((Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ModSummary -> [Located ModuleName]
ms_home_imps ModSummary
s)) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
(
if Bool
drop_hs_boot_nodes Bool -> Bool -> Bool
|| ModSummary -> HscSource
ms_hsc_src ModSummary
s HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsBootFile
then []
else case HscSource -> ModuleName -> Maybe Int
lookup_key HscSource
HsBootFile (ModSummary -> ModuleName
ms_mod_name ModSummary
s) of
Nothing -> []
Just k :: Int
k -> [Int
k]) ]
hs_boot_key :: HscSource
hs_boot_key | Bool
drop_hs_boot_nodes = HscSource
HsSrcFile
| Bool
otherwise = HscSource
HsBootFile
out_edge_keys :: HscSource -> [ModuleName] -> [Int]
out_edge_keys :: HscSource -> [ModuleName] -> [Int]
out_edge_keys hi_boot :: HscSource
hi_boot ms :: [ModuleName]
ms = (ModuleName -> Maybe Int) -> [ModuleName] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (HscSource -> ModuleName -> Maybe Int
lookup_key HscSource
hi_boot) [ModuleName]
ms
type NodeKey = (ModuleName, IsBoot)
type NodeMap a = Map.Map NodeKey a
msKey :: ModSummary -> NodeKey
msKey :: ModSummary -> (ModuleName, IsBoot)
msKey (ModSummary { ms_mod :: ModSummary -> Module
ms_mod = Module
mod, ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
boot })
= (Module -> ModuleName
moduleName Module
mod, HscSource -> IsBoot
hscSourceToIsBoot HscSource
boot)
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap :: [ModSummary] -> NodeMap ModSummary
mkNodeMap summaries :: [ModSummary]
summaries = [((ModuleName, IsBoot), ModSummary)] -> NodeMap ModSummary
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModSummary -> (ModuleName, IsBoot)
msKey ModSummary
s, ModSummary
s) | ModSummary
s <- [ModSummary]
summaries]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = NodeMap a -> [a]
forall k a. Map k a -> [a]
Map.elems
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports :: [SCC ModSummary] -> m ()
warnUnnecessarySourceImports sccs :: [SCC ModSummary]
sccs = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnusedImports DynFlags
dflags)
(ErrorMessages -> m ()
forall (m :: * -> *). GhcMonad m => ErrorMessages -> m ()
logWarnings ([ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag ((SCC ModSummary -> [ErrMsg]) -> [SCC ModSummary] -> [ErrMsg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags -> [ModSummary] -> [ErrMsg]
check DynFlags
dflags ([ModSummary] -> [ErrMsg])
-> (SCC ModSummary -> [ModSummary]) -> SCC ModSummary -> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC ModSummary -> [ModSummary]
forall vertex. SCC vertex -> [vertex]
flattenSCC) [SCC ModSummary]
sccs)))
where check :: DynFlags -> [ModSummary] -> [ErrMsg]
check dflags :: DynFlags
dflags ms :: [ModSummary]
ms =
let mods_in_this_cycle :: [ModuleName]
mods_in_this_cycle = (ModSummary -> ModuleName) -> [ModSummary] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModSummary -> ModuleName
ms_mod_name [ModSummary]
ms in
[ DynFlags -> Located ModuleName -> ErrMsg
warn DynFlags
dflags Located ModuleName
i | ModSummary
m <- [ModSummary]
ms, Located ModuleName
i <- ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
m,
Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
i ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
mods_in_this_cycle ]
warn :: DynFlags -> Located ModuleName -> WarnMsg
warn :: DynFlags -> Located ModuleName -> ErrMsg
warn dflags :: DynFlags
dflags (L loc :: SrcSpan
loc mod :: ModuleName
mod) =
DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
loc
(String -> SDoc
text "Warning: {-# SOURCE #-} unnecessary in import of "
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod))
reportImportErrors :: MonadIO m => [Either ErrorMessages b] -> m [b]
reportImportErrors :: [Either ErrorMessages b] -> m [b]
reportImportErrors xs :: [Either ErrorMessages b]
xs | [ErrorMessages] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrorMessages]
errs = [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b]
oks
| Bool
otherwise = ErrorMessages -> m [b]
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors (ErrorMessages -> m [b]) -> ErrorMessages -> m [b]
forall a b. (a -> b) -> a -> b
$ [ErrorMessages] -> ErrorMessages
forall a. [Bag a] -> Bag a
unionManyBags [ErrorMessages]
errs
where (errs :: [ErrorMessages]
errs, oks :: [b]
oks) = [Either ErrorMessages b] -> ([ErrorMessages], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ErrorMessages b]
xs
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ModSummary]
downsweep :: HscEnv
-> [ModSummary]
-> [ModuleName]
-> Bool
-> IO [Either ErrorMessages ModSummary]
downsweep hsc_env :: HscEnv
hsc_env old_summaries :: [ModSummary]
old_summaries excl_mods :: [ModuleName]
excl_mods allow_dup_roots :: Bool
allow_dup_roots
= do
[Either ErrorMessages ModSummary]
rootSummaries <- (Target -> IO (Either ErrorMessages ModSummary))
-> [Target] -> IO [Either ErrorMessages ModSummary]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Target -> IO (Either ErrorMessages ModSummary)
getRootSummary [Target]
roots
[ModSummary]
rootSummariesOk <- [Either ErrorMessages ModSummary] -> IO [ModSummary]
forall (m :: * -> *) b.
MonadIO m =>
[Either ErrorMessages b] -> m [b]
reportImportErrors [Either ErrorMessages ModSummary]
rootSummaries
let root_map :: NodeMap [Either ErrorMessages ModSummary]
root_map = [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap [ModSummary]
rootSummariesOk
NodeMap [Either ErrorMessages ModSummary] -> IO ()
checkDuplicates NodeMap [Either ErrorMessages ModSummary]
root_map
NodeMap [Either ErrorMessages ModSummary]
map0 <- [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop ((ModSummary -> [(Located ModuleName, IsBoot)])
-> [ModSummary] -> [(Located ModuleName, IsBoot)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ModSummary -> [(Located ModuleName, IsBoot)]
calcDeps [ModSummary]
rootSummariesOk) NodeMap [Either ErrorMessages ModSummary]
root_map
NodeMap [Either ErrorMessages ModSummary]
map1 <- if DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing
then HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH
(Platform -> HscTarget
defaultObjectTarget (DynFlags -> Platform
targetPlatform DynFlags
dflags))
NodeMap [Either ErrorMessages ModSummary]
map0
else if DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted
then HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuples
(Platform -> HscTarget
defaultObjectTarget (DynFlags -> Platform
targetPlatform DynFlags
dflags))
NodeMap [Either ErrorMessages ModSummary]
map0
else NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
map0
[Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary])
-> [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ [[Either ErrorMessages ModSummary]]
-> [Either ErrorMessages ModSummary]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either ErrorMessages ModSummary]]
-> [Either ErrorMessages ModSummary])
-> [[Either ErrorMessages ModSummary]]
-> [Either ErrorMessages ModSummary]
forall a b. (a -> b) -> a -> b
$ NodeMap [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall a. NodeMap a -> [a]
nodeMapElts NodeMap [Either ErrorMessages ModSummary]
map1
where
calcDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
calcDeps = ModSummary -> [(Located ModuleName, IsBoot)]
msDeps
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
roots :: [Target]
roots = HscEnv -> [Target]
hsc_targets HscEnv
hsc_env
old_summary_map :: NodeMap ModSummary
old_summary_map :: NodeMap ModSummary
old_summary_map = [ModSummary] -> NodeMap ModSummary
mkNodeMap [ModSummary]
old_summaries
getRootSummary :: Target -> IO (Either ErrorMessages ModSummary)
getRootSummary :: Target -> IO (Either ErrorMessages ModSummary)
getRootSummary (Target (TargetFile file :: String
file mb_phase :: Maybe Phase
mb_phase) obj_allowed :: Bool
obj_allowed maybe_buf :: Maybe (InputFileBuffer, UTCTime)
maybe_buf)
= do Bool
exists <- IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
file
if Bool
exists Bool -> Bool -> Bool
|| Maybe (InputFileBuffer, UTCTime) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (InputFileBuffer, UTCTime)
maybe_buf
then HscEnv
-> [ModSummary]
-> String
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ModSummary)
summariseFile HscEnv
hsc_env [ModSummary]
old_summaries String
file Maybe Phase
mb_phase
Bool
obj_allowed Maybe (InputFileBuffer, UTCTime)
maybe_buf
else Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary))
-> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages ModSummary
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages ModSummary)
-> ErrorMessages -> Either ErrorMessages ModSummary
forall a b. (a -> b) -> a -> b
$ ErrMsg -> ErrorMessages
forall a. a -> Bag a
unitBag (ErrMsg -> ErrorMessages) -> ErrMsg -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
noSrcSpan (SDoc -> ErrMsg) -> SDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text "can't find file:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
file
getRootSummary (Target (TargetModule modl :: ModuleName
modl) obj_allowed :: Bool
obj_allowed maybe_buf :: Maybe (InputFileBuffer, UTCTime)
maybe_buf)
= do Maybe (Either ErrorMessages ModSummary)
maybe_summary <- HscEnv
-> NodeMap ModSummary
-> IsBoot
-> Located ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule HscEnv
hsc_env NodeMap ModSummary
old_summary_map IsBoot
NotBoot
(SrcSpan -> ModuleName -> Located ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
rootLoc ModuleName
modl) Bool
obj_allowed
Maybe (InputFileBuffer, UTCTime)
maybe_buf [ModuleName]
excl_mods
case Maybe (Either ErrorMessages ModSummary)
maybe_summary of
Nothing -> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary))
-> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> Either ErrorMessages ModSummary
forall a b. a -> Either a b
Left (ErrorMessages -> Either ErrorMessages ModSummary)
-> ErrorMessages -> Either ErrorMessages ModSummary
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> ErrorMessages
moduleNotFoundErr DynFlags
dflags ModuleName
modl
Just s :: Either ErrorMessages ModSummary
s -> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return Either ErrorMessages ModSummary
s
rootLoc :: SrcSpan
rootLoc = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
fsLit "<command line>")
checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO ()
checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO ()
checkDuplicates root_map :: NodeMap [Either ErrorMessages ModSummary]
root_map
| Bool
allow_dup_roots = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| [[ModSummary]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[ModSummary]]
dup_roots = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> [ModSummary] -> IO ()
multiRootsErr DynFlags
dflags ([[ModSummary]] -> [ModSummary]
forall a. [a] -> a
head [[ModSummary]]
dup_roots)
where
dup_roots :: [[ModSummary]]
dup_roots :: [[ModSummary]]
dup_roots = ([ModSummary] -> Bool) -> [[ModSummary]] -> [[ModSummary]]
forall a. (a -> Bool) -> [a] -> [a]
filterOut [ModSummary] -> Bool
forall a. [a] -> Bool
isSingleton ([[ModSummary]] -> [[ModSummary]])
-> [[ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> a -> b
$ ([Either ErrorMessages ModSummary] -> [ModSummary])
-> [[Either ErrorMessages ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> [a] -> [b]
map [Either ErrorMessages ModSummary] -> [ModSummary]
forall a b. [Either a b] -> [b]
rights ([[Either ErrorMessages ModSummary]] -> [[ModSummary]])
-> [[Either ErrorMessages ModSummary]] -> [[ModSummary]]
forall a b. (a -> b) -> a -> b
$ NodeMap [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall a. NodeMap a -> [a]
nodeMapElts NodeMap [Either ErrorMessages ModSummary]
root_map
loop :: [(Located ModuleName,IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop :: [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [] done :: NodeMap [Either ErrorMessages ModSummary]
done = NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
done
loop ((wanted_mod :: Located ModuleName
wanted_mod, is_boot :: IsBoot
is_boot) : ss :: [(Located ModuleName, IsBoot)]
ss) done :: NodeMap [Either ErrorMessages ModSummary]
done
| Just summs :: [Either ErrorMessages ModSummary]
summs <- (ModuleName, IsBoot)
-> NodeMap [Either ErrorMessages ModSummary]
-> Maybe [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModuleName, IsBoot)
key NodeMap [Either ErrorMessages ModSummary]
done
= if [Either ErrorMessages ModSummary] -> Bool
forall a. [a] -> Bool
isSingleton [Either ErrorMessages ModSummary]
summs then
[(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [(Located ModuleName, IsBoot)]
ss NodeMap [Either ErrorMessages ModSummary]
done
else
do { DynFlags -> [ModSummary] -> IO ()
multiRootsErr DynFlags
dflags ([Either ErrorMessages ModSummary] -> [ModSummary]
forall a b. [Either a b] -> [b]
rights [Either ErrorMessages ModSummary]
summs); NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (m :: * -> *) a. Monad m => a -> m a
return NodeMap [Either ErrorMessages ModSummary]
forall k a. Map k a
Map.empty }
| Bool
otherwise
= do Maybe (Either ErrorMessages ModSummary)
mb_s <- HscEnv
-> NodeMap ModSummary
-> IsBoot
-> Located ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule HscEnv
hsc_env NodeMap ModSummary
old_summary_map
IsBoot
is_boot Located ModuleName
wanted_mod Bool
True
Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing [ModuleName]
excl_mods
case Maybe (Either ErrorMessages ModSummary)
mb_s of
Nothing -> [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [(Located ModuleName, IsBoot)]
ss NodeMap [Either ErrorMessages ModSummary]
done
Just (Left e :: ErrorMessages
e) -> [(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [(Located ModuleName, IsBoot)]
ss ((ModuleName, IsBoot)
-> [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ModuleName, IsBoot)
key [ErrorMessages -> Either ErrorMessages ModSummary
forall a b. a -> Either a b
Left ErrorMessages
e] NodeMap [Either ErrorMessages ModSummary]
done)
Just (Right s :: ModSummary
s)-> do
NodeMap [Either ErrorMessages ModSummary]
new_map <-
[(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop (ModSummary -> [(Located ModuleName, IsBoot)]
calcDeps ModSummary
s) ((ModuleName, IsBoot)
-> [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ModuleName, IsBoot)
key [ModSummary -> Either ErrorMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s] NodeMap [Either ErrorMessages ModSummary]
done)
[(Located ModuleName, IsBoot)]
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
loop [(Located ModuleName, IsBoot)]
ss NodeMap [Either ErrorMessages ModSummary]
new_map
where
key :: (ModuleName, IsBoot)
key = (Located ModuleName -> SrcSpanLess (Located ModuleName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located ModuleName
wanted_mod, IsBoot
is_boot)
enableCodeGenForTH :: HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH :: HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH =
(ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
TFL_CurrentModule TempFileLifetime
TFL_GhcSession
where
condition :: ModSummary -> Bool
condition = ModSummary -> Bool
isTemplateHaskellOrQQNonBoot
should_modify :: ModSummary -> Bool
should_modify (ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscNothing Bool -> Bool -> Bool
&&
Bool -> Bool
not (DynFlags -> Bool
isIndefinite DynFlags
dflags)
enableCodeGenForUnboxedTuples :: HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuples :: HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuples =
(ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen ModSummary -> Bool
condition ModSummary -> Bool
should_modify TempFileLifetime
TFL_GhcSession TempFileLifetime
TFL_CurrentModule
where
condition :: ModSummary -> Bool
condition ms :: ModSummary
ms =
Bool
False Bool -> Bool -> Bool
&&
Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnboxedTuples (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms) Bool -> Bool -> Bool
&&
Bool -> Bool
not (ModSummary -> Bool
isBootSummary ModSummary
ms)
should_modify :: ModSummary -> Bool
should_modify (ModSummary { ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags }) =
DynFlags -> HscTarget
hscTarget DynFlags
dflags HscTarget -> HscTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HscTarget
HscInterpreted
enableCodeGenWhen
:: (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen :: (ModSummary -> Bool)
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen condition :: ModSummary -> Bool
condition should_modify :: ModSummary -> Bool
should_modify staticLife :: TempFileLifetime
staticLife dynLife :: TempFileLifetime
dynLife target :: HscTarget
target nodemap :: NodeMap [Either ErrorMessages ModSummary]
nodemap =
([Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary])
-> NodeMap [Either ErrorMessages ModSummary]
-> IO (NodeMap [Either ErrorMessages ModSummary])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary))
-> [Either ErrorMessages ModSummary]
-> IO [Either ErrorMessages ModSummary]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ModSummary -> IO ModSummary)
-> Either ErrorMessages ModSummary
-> IO (Either ErrorMessages ModSummary)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ModSummary -> IO ModSummary
enable_code_gen)) NodeMap [Either ErrorMessages ModSummary]
nodemap
where
enable_code_gen :: ModSummary -> IO ModSummary
enable_code_gen ms :: ModSummary
ms
| ModSummary
{ ms_mod :: ModSummary -> Module
ms_mod = Module
ms_mod
, ms_location :: ModSummary -> ModLocation
ms_location = ModLocation
ms_location
, ms_hsc_src :: ModSummary -> HscSource
ms_hsc_src = HscSource
HsSrcFile
, ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dflags
} <- ModSummary
ms
, ModSummary -> Bool
should_modify ModSummary
ms
, Module
ms_mod Module -> Set Module -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
needs_codegen_set
= do
let new_temp_file :: String -> String -> IO String
new_temp_file suf :: String
suf dynsuf :: String
dynsuf = do
String
tn <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
staticLife String
suf
let dyn_tn :: String
dyn_tn = String
tn String -> String -> String
-<.> String
dynsuf
DynFlags -> TempFileLifetime -> [String] -> IO ()
addFilesToClean DynFlags
dflags TempFileLifetime
dynLife [String
dyn_tn]
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tn
String
hi_file <-
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ ModLocation -> String
ml_hi_file ModLocation
ms_location
else String -> String -> IO String
new_temp_file (DynFlags -> String
hiSuf DynFlags
dflags) (DynFlags -> String
dynHiSuf DynFlags
dflags)
String
o_temp_file <- String -> String -> IO String
new_temp_file (DynFlags -> String
objectSuf DynFlags
dflags) (DynFlags -> String
dynObjectSuf DynFlags
dflags)
ModSummary -> IO ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> IO ModSummary) -> ModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$
ModSummary
ms
{ ms_location :: ModLocation
ms_location =
ModLocation
ms_location {ml_hi_file :: String
ml_hi_file = String
hi_file, ml_obj_file :: String
ml_obj_file = String
o_temp_file}
, ms_hspp_opts :: DynFlags
ms_hspp_opts = Int -> DynFlags -> DynFlags
updOptLevel 0 (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags {hscTarget :: HscTarget
hscTarget = HscTarget
target}
}
| Bool
otherwise = ModSummary -> IO ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
ms
needs_codegen_set :: Set Module
needs_codegen_set = [ModSummary] -> Set Module
forall (t :: * -> *). Foldable t => t ModSummary -> Set Module
transitive_deps_set
[ ModSummary
ms
| [Either ErrorMessages ModSummary]
mss <- NodeMap [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall k a. Map k a -> [a]
Map.elems NodeMap [Either ErrorMessages ModSummary]
nodemap
, Right ms :: ModSummary
ms <- [Either ErrorMessages ModSummary]
mss
, ModSummary -> Bool
condition ModSummary
ms
]
transitive_deps_set :: t ModSummary -> Set Module
transitive_deps_set modSums :: t ModSummary
modSums = (Set Module -> ModSummary -> Set Module)
-> Set Module -> t ModSummary -> Set Module
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go Set Module
forall a. Set a
Set.empty t ModSummary
modSums
where
go :: Set Module -> ModSummary -> Set Module
go marked_mods :: Set Module
marked_mods ms :: ModSummary
ms@ModSummary{Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod}
| Module
ms_mod Module -> Set Module -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Module
marked_mods = Set Module
marked_mods
| Bool
otherwise =
let deps :: [ModSummary]
deps =
[ ModSummary
dep_ms
| (L _ mn :: ModuleName
mn, NotBoot) <- ModSummary -> [(Located ModuleName, IsBoot)]
msDeps ModSummary
ms
, ModSummary
dep_ms <-
Maybe [Either ErrorMessages ModSummary]
-> [[Either ErrorMessages ModSummary]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((ModuleName, IsBoot)
-> NodeMap [Either ErrorMessages ModSummary]
-> Maybe [Either ErrorMessages ModSummary]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModuleName
mn, IsBoot
NotBoot) NodeMap [Either ErrorMessages ModSummary]
nodemap) [[Either ErrorMessages ModSummary]]
-> ([Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary])
-> [Either ErrorMessages ModSummary]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Either ErrorMessages ModSummary]
-> (Either ErrorMessages ModSummary -> [ModSummary])
-> [ModSummary]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Either ErrorMessages ModSummary -> [ModSummary]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
]
new_marked_mods :: Set Module
new_marked_mods = Module -> Set Module -> Set Module
forall a. Ord a => a -> Set a -> Set a
Set.insert Module
ms_mod Set Module
marked_mods
in (Set Module -> ModSummary -> Set Module)
-> Set Module -> [ModSummary] -> Set Module
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set Module -> ModSummary -> Set Module
go Set Module
new_marked_mods [ModSummary]
deps
mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap summaries :: [ModSummary]
summaries = ([Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary])
-> [((ModuleName, IsBoot), [Either ErrorMessages ModSummary])]
-> NodeMap [Either ErrorMessages ModSummary]
-> NodeMap [Either ErrorMessages ModSummary]
forall key elt.
Ord key =>
(elt -> elt -> elt) -> [(key, elt)] -> Map key elt -> Map key elt
Map.insertListWith (([Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary])
-> [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
-> [Either ErrorMessages ModSummary]
forall a. [a] -> [a] -> [a]
(++))
[ (ModSummary -> (ModuleName, IsBoot)
msKey ModSummary
s, [ModSummary -> Either ErrorMessages ModSummary
forall a b. b -> Either a b
Right ModSummary
s]) | ModSummary
s <- [ModSummary]
summaries ]
NodeMap [Either ErrorMessages ModSummary]
forall k a. Map k a
Map.empty
msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
msDeps s :: ModSummary
s =
[[(Located ModuleName, IsBoot)]] -> [(Located ModuleName, IsBoot)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(Located ModuleName
m,IsBoot
IsBoot), (Located ModuleName
m,IsBoot
NotBoot)] | Located ModuleName
m <- ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
s ]
[(Located ModuleName, IsBoot)]
-> [(Located ModuleName, IsBoot)] -> [(Located ModuleName, IsBoot)]
forall a. [a] -> [a] -> [a]
++ [ (Located ModuleName
m,IsBoot
NotBoot) | Located ModuleName
m <- ModSummary -> [Located ModuleName]
ms_home_imps ModSummary
s ]
home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps imps :: [(Maybe FastString, Located ModuleName)]
imps = [ Located ModuleName
lmodname | (mb_pkg :: Maybe FastString
mb_pkg, lmodname :: Located ModuleName
lmodname) <- [(Maybe FastString, Located ModuleName)]
imps,
Maybe FastString -> Bool
isLocal Maybe FastString
mb_pkg ]
where isLocal :: Maybe FastString -> Bool
isLocal Nothing = Bool
True
isLocal (Just pkg :: FastString
pkg) | FastString
pkg FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FastString
fsLit "this" = Bool
True
isLocal _ = Bool
False
ms_home_allimps :: ModSummary -> [ModuleName]
ms_home_allimps :: ModSummary -> [ModuleName]
ms_home_allimps ms :: ModSummary
ms = (Located ModuleName -> ModuleName)
-> [Located ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map Located ModuleName -> ModuleName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ModSummary -> [Located ModuleName]
ms_home_srcimps ModSummary
ms [Located ModuleName]
-> [Located ModuleName] -> [Located ModuleName]
forall a. [a] -> [a] -> [a]
++ ModSummary -> [Located ModuleName]
ms_home_imps ModSummary
ms)
ms_home_srcimps :: ModSummary -> [Located ModuleName]
ms_home_srcimps :: ModSummary -> [Located ModuleName]
ms_home_srcimps = [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps ([(Maybe FastString, Located ModuleName)] -> [Located ModuleName])
-> (ModSummary -> [(Maybe FastString, Located ModuleName)])
-> ModSummary
-> [Located ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_srcimps
ms_home_imps :: ModSummary -> [Located ModuleName]
ms_home_imps :: ModSummary -> [Located ModuleName]
ms_home_imps = [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
home_imps ([(Maybe FastString, Located ModuleName)] -> [Located ModuleName])
-> (ModSummary -> [(Maybe FastString, Located ModuleName)])
-> ModSummary
-> [Located ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_imps
summariseFile
:: HscEnv
-> [ModSummary]
-> FilePath
-> Maybe Phase
-> Bool
-> Maybe (StringBuffer,UTCTime)
-> IO (Either ErrorMessages ModSummary)
summariseFile :: HscEnv
-> [ModSummary]
-> String
-> Maybe Phase
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> IO (Either ErrorMessages ModSummary)
summariseFile hsc_env :: HscEnv
hsc_env old_summaries :: [ModSummary]
old_summaries src_fn :: String
src_fn mb_phase :: Maybe Phase
mb_phase obj_allowed :: Bool
obj_allowed maybe_buf :: Maybe (InputFileBuffer, UTCTime)
maybe_buf
| Just old_summary :: ModSummary
old_summary <- [ModSummary] -> String -> Maybe ModSummary
findSummaryBySourceFile [ModSummary]
old_summaries String
src_fn
= do
let location :: ModLocation
location = ModSummary -> ModLocation
ms_location ModSummary
old_summary
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
HscEnv
-> DynFlags
-> Bool
-> IsBoot
-> (UTCTime -> IO (Either ErrorMessages ModSummary))
-> ModSummary
-> ModLocation
-> UTCTime
-> IO (Either ErrorMessages ModSummary)
forall e.
HscEnv
-> DynFlags
-> Bool
-> IsBoot
-> (UTCTime -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ModSummary)
checkSummaryTimestamp
HscEnv
hsc_env DynFlags
dflags Bool
obj_allowed IsBoot
NotBoot (String -> UTCTime -> IO (Either ErrorMessages ModSummary)
new_summary String
src_fn)
ModSummary
old_summary ModLocation
location UTCTime
src_timestamp
| Bool
otherwise
= do UTCTime
src_timestamp <- IO UTCTime
get_src_timestamp
String -> UTCTime -> IO (Either ErrorMessages ModSummary)
new_summary String
src_fn UTCTime
src_timestamp
where
get_src_timestamp :: IO UTCTime
get_src_timestamp = case Maybe (InputFileBuffer, UTCTime)
maybe_buf of
Just (_,t :: UTCTime
t) -> UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t
Nothing -> IO UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> IO UTCTime) -> IO UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ String -> IO UTCTime
getModificationUTCTime String
src_fn
new_summary :: String -> UTCTime -> IO (Either ErrorMessages ModSummary)
new_summary src_fn :: String
src_fn src_timestamp :: UTCTime
src_timestamp = ExceptT ErrorMessages IO ModSummary
-> IO (Either ErrorMessages ModSummary)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorMessages IO ModSummary
-> IO (Either ErrorMessages ModSummary))
-> ExceptT ErrorMessages IO ModSummary
-> IO (Either ErrorMessages ModSummary)
forall a b. (a -> b) -> a -> b
$ do
preimps :: PreprocessedImports
preimps@PreprocessedImports {..}
<- HscEnv
-> String
-> Maybe Phase
-> Maybe (InputFileBuffer, UTCTime)
-> ExceptT ErrorMessages IO PreprocessedImports
getPreprocessedImports HscEnv
hsc_env String
src_fn Maybe Phase
mb_phase Maybe (InputFileBuffer, UTCTime)
maybe_buf
ModLocation
location <- IO ModLocation -> ExceptT ErrorMessages IO ModLocation
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModLocation -> ExceptT ErrorMessages IO ModLocation)
-> IO ModLocation -> ExceptT ErrorMessages IO ModLocation
forall a b. (a -> b) -> a -> b
$ DynFlags -> ModuleName -> String -> IO ModLocation
mkHomeModLocation (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) ModuleName
pi_mod_name String
src_fn
Module
mod <- IO Module -> ExceptT ErrorMessages IO Module
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Module -> ExceptT ErrorMessages IO Module)
-> IO Module -> ExceptT ErrorMessages IO Module
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env ModuleName
pi_mod_name ModLocation
location
IO ModSummary -> ExceptT ErrorMessages IO ModSummary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModSummary -> ExceptT ErrorMessages IO ModSummary)
-> IO ModSummary -> ExceptT ErrorMessages IO ModSummary
forall a b. (a -> b) -> a -> b
$ HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary HscEnv
hsc_env (MakeNewModSummary -> IO ModSummary)
-> MakeNewModSummary -> IO ModSummary
forall a b. (a -> b) -> a -> b
$ MakeNewModSummary :: String
-> UTCTime
-> IsBoot
-> HscSource
-> ModLocation
-> Module
-> Bool
-> PreprocessedImports
-> MakeNewModSummary
MakeNewModSummary
{ nms_src_fn :: String
nms_src_fn = String
src_fn
, nms_src_timestamp :: UTCTime
nms_src_timestamp = UTCTime
src_timestamp
, nms_is_boot :: IsBoot
nms_is_boot = IsBoot
NotBoot
, nms_hsc_src :: HscSource
nms_hsc_src =
if String -> Bool
isHaskellSigFilename String
src_fn
then HscSource
HsigFile
else HscSource
HsSrcFile
, nms_location :: ModLocation
nms_location = ModLocation
location
, nms_mod :: Module
nms_mod = Module
mod
, nms_obj_allowed :: Bool
nms_obj_allowed = Bool
obj_allowed
, nms_preimps :: PreprocessedImports
nms_preimps = PreprocessedImports
preimps
}
findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
findSummaryBySourceFile :: [ModSummary] -> String -> Maybe ModSummary
findSummaryBySourceFile summaries :: [ModSummary]
summaries file :: String
file
= case [ ModSummary
ms | ModSummary
ms <- [ModSummary]
summaries, HscSource
HsSrcFile <- [ModSummary -> HscSource
ms_hsc_src ModSummary
ms],
String -> Maybe String -> String
forall a. HasCallStack => String -> Maybe a -> a
expectJust "findSummaryBySourceFile" (ModLocation -> Maybe String
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
ms)) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
file ] of
[] -> Maybe ModSummary
forall a. Maybe a
Nothing
(x :: ModSummary
x:_) -> ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
x
checkSummaryTimestamp
:: HscEnv -> DynFlags -> Bool -> IsBoot
-> (UTCTime -> IO (Either e ModSummary))
-> ModSummary -> ModLocation -> UTCTime
-> IO (Either e ModSummary)
checkSummaryTimestamp :: HscEnv
-> DynFlags
-> Bool
-> IsBoot
-> (UTCTime -> IO (Either e ModSummary))
-> ModSummary
-> ModLocation
-> UTCTime
-> IO (Either e ModSummary)
checkSummaryTimestamp
hsc_env :: HscEnv
hsc_env dflags :: DynFlags
dflags obj_allowed :: Bool
obj_allowed is_boot :: IsBoot
is_boot new_summary :: UTCTime -> IO (Either e ModSummary)
new_summary
old_summary :: ModSummary
old_summary location :: ModLocation
location src_timestamp :: UTCTime
src_timestamp
| ModSummary -> UTCTime
ms_hs_date ModSummary
old_summary UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
src_timestamp Bool -> Bool -> Bool
&&
Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ForceRecomp (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) = do
Maybe UTCTime
obj_timestamp <-
if HscTarget -> Bool
isObjectTarget (DynFlags -> HscTarget
hscTarget (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
Bool -> Bool -> Bool
|| Bool
obj_allowed
then IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe UTCTime) -> IO (Maybe UTCTime))
-> IO (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ ModLocation -> IsBoot -> IO (Maybe UTCTime)
getObjTimestamp ModLocation
location IsBoot
is_boot
else Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
Module
_ <- HscEnv -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder HscEnv
hsc_env
(Module -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
old_summary)) ModLocation
location
Maybe UTCTime
hi_timestamp <- DynFlags -> ModLocation -> IO (Maybe UTCTime)
maybeGetIfaceDate DynFlags
dflags ModLocation
location
Maybe UTCTime
hie_timestamp <- String -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> String
ml_hie_file ModLocation
location)
Either e ModSummary -> IO (Either e ModSummary)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e ModSummary -> IO (Either e ModSummary))
-> Either e ModSummary -> IO (Either e ModSummary)
forall a b. (a -> b) -> a -> b
$ ModSummary -> Either e ModSummary
forall a b. b -> Either a b
Right ModSummary
old_summary
{ ms_obj_date :: Maybe UTCTime
ms_obj_date = Maybe UTCTime
obj_timestamp
, ms_iface_date :: Maybe UTCTime
ms_iface_date = Maybe UTCTime
hi_timestamp
, ms_hie_date :: Maybe UTCTime
ms_hie_date = Maybe UTCTime
hie_timestamp
}
| Bool
otherwise =
UTCTime -> IO (Either e ModSummary)
new_summary UTCTime
src_timestamp
summariseModule
:: HscEnv
-> NodeMap ModSummary
-> IsBoot
-> Located ModuleName
-> Bool
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule :: HscEnv
-> NodeMap ModSummary
-> IsBoot
-> Located ModuleName
-> Bool
-> Maybe (InputFileBuffer, UTCTime)
-> [ModuleName]
-> IO (Maybe (Either ErrorMessages ModSummary))
summariseModule hsc_env :: HscEnv
hsc_env old_summary_map :: NodeMap ModSummary
old_summary_map is_boot :: IsBoot
is_boot (