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