{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE ViewPatterns #-} module GHC.Driver.Downsweep ( downsweep , downsweepThunk , downsweepInstalledModules , downsweepFromRootNodes , downsweepInteractiveImports , DownsweepMode(..) -- * Summary functions , summariseModule , summariseFile , summariseModuleInterface , SummariseResult(..) -- * Helper functions , instantiationNodes , checkHomeUnitsClosed ) where import GHC.Prelude import GHC.Platform.Ways import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Phases import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess) 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.Messager import GHC.Driver.MakeSem import GHC.Driver.MakeAction import GHC.Driver.Config.Diagnostic import GHC.Driver.Ppr import GHC.Iface.Load import GHC.Parser.Header import GHC.Rename.Names import GHC.Tc.Utils.Backpack import GHC.Runtime.Context import Language.Haskell.Syntax.ImpExp import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) import qualified GHC.Data.Maybe as M import GHC.Data.OsPath ( unsafeEncodeUtf ) import GHC.Data.StringBuffer import GHC.Data.Graph.Directed.Reachability import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Exception ( throwIO, SomeAsyncException ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs import GHC.Utils.Constants import GHC.Types.Error import GHC.Types.Target import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.Map import GHC.Types.PkgQual import GHC.Types.Basic 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.Module.Deps import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Module.Stage import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set import Control.Concurrent.MVar import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.Maybe import Data.List (partition) import Data.Time import Data.List (unfoldr) import Data.Bifunctor (first, bimap) import System.Directory import System.FilePath import Control.Monad.Trans.Reader import qualified Data.Map.Strict as M import Control.Monad.Trans.Class import System.IO.Unsafe (unsafeInterleaveIO) {- Note [Downsweep and the ModuleGraph] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ModuleGraph stores the relationship between all the modules, units, and instantiations in the current session. When we do downsweep, we build up a new ModuleGraph, starting from the root modules. By following all the dependencies we construct a graph which allows us to answer questions about the transitive closure of the imports. The module graph is accessible in the HscEnv. When is this graph constructed? 1. In `--make` mode, we construct the graph before starting to do any compilation. 2. In `-c` (oneshot) mode, we construct the graph when we have calculated the ModSummary for the module we are compiling. The `ModuleGraph` is stored in a thunk, so it is only constructed when it is needed. This avoids reading the interface files of the whole transitive closure unless they are needed. 3. In some situations (such as loading plugins) we may need to construct the graph without having a ModSummary. In this case we use the `downsweepInstalledModules` function. The result is having a uniform graph available for the whole compilation pipeline. -} -- This caches the answer to the question, if we are in this unit, what does -- an import of this module mean. type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo] ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) for --make mode -- -- Chase downwards from the specified root set, returning summaries -- for all home modules encountered. Only follow source-import -- links. -- -- We pass in the previous collection of summaries, which is used as a -- cache to avoid recalculating a module summary if the source is -- unchanged. -- -- The returned ModuleGraph has one node for each home-package -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. -- -- This function is intendned for use by --make mode and will also insert -- LinkNodes and InstantiationNodes for any home units. -- -- It will also turn on code generation for any modules that need it by calling -- 'enableCodeGenForTH'. downsweep :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [ModSummary] -- ^ Old summaries -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have -- the same module name; this is -- very useful for ghc -M -> IO ([DriverMessages], ModuleGraph) -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary let closure_errs = checkHomeUnitsClosed unit_env unit_env = hsc_unit_env hsc_env all_errs = closure_errs ++ root_errs case all_errs of [] -> do (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) let all_nodes = downsweep_nodes ++ unit_nodes let all_errs = downsweep_errs ++ other_errs let logger = hsc_logger hsc_env tmpfs = hsc_tmpfs hsc_env -- if we have been passed -fno-code, we enable code generation -- for dependencies of modules that have -XTemplateHaskell, -- otherwise those modules will fail to compile. -- See Note [-fno-code mode] #8025 th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes return (all_errs, th_configured_nodes) _ -> return (all_errs, emptyMG) where summary = getRootSummary excl_mods old_summary_map -- A cache from file paths to the already summarised modules. The same file -- can be used in multiple units so the map is also keyed by which unit the -- file was used in. -- Reuse these if we can because the most expensive part of downsweep is -- reading the headers. old_summary_map :: M.Map (UnitId, FilePath) ModSummary old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] -- Dependencies arising on a unit (backpack and module linking deps) unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] unitModuleNodes summaries uid hue = maybeToList (linkNodes summaries uid hue) -- | Calculate the module graph starting from a single ModSummary. The result is a -- thunk, which when forced will perform the downsweep. This is useful in oneshot -- mode where the module graph may never be needed. -- If downsweep fails, then the resulting errors are just thrown. downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] let dflags = hsc_dflags hsc_env liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> unionManyMessages errs) return (mkModuleGraph mg) -- | Construct a module graph starting from the interactive context. -- Produces, a thunk, which when forced will perform the downsweep. -- This graph contains the current interactive module, and its dependencies. -- -- Invariant: The hsc_mod_graph already contains the relevant home modules which -- might be imported by the interactive imports. -- -- This is a first approximation for this function. There probably should also -- be edges linking the interactive modules together. (Ie Ghci7 importing Ghci6 -- and so on) -- See Note [runTcInteractive module graph] downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...") let imps = ic_imports (hsc_IC hsc_env) let interactive_mn = icInteractiveModule ic -- No sensible value for ModLocation.. if you hit this panic then you probably -- need to add proper support for modules without any source files to the driver. let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps) let key = moduleToMnk interactive_mn NotBoot let node_type = ModuleNodeFixed key ml -- The existing nodes in the module graph. This will be populated when GHCi runs -- :load. Any home package modules need to already be in here. let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ] (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes let interactive_node = ModuleNode module_edges node_type let all_nodes = M.elems graph return $ mkModuleGraph (interactive_node : all_nodes) where -- mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) -- A simple edge to a module from the same home unit mkEdge (IIModule n) = let mod_node_key = ModNodeKeyWithUid { mnkModuleName = GWIB (moduleName n) NotBoot , mnkUnitId = -- 'toUnitId' is safe here, as we can't import modules that -- don't have a 'UnitId'. toUnitId (moduleUnit n) } mod_node_edge = ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key) in Left mod_node_edge -- A complete import statement mkEdge (IIDecl i) = let lvl = convImportLevel (ideclLevelSpec i) wanted_mod = unLoc (ideclName i) is_boot = ideclSource i mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) unitId = homeUnitId $ hsc_home_unit hsc_env in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) loopFromInteractive :: HscEnv -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] -> M.Map NodeKey ModuleGraphNode -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode) loopFromInteractive _ [] cached_nodes = return ([], cached_nodes) loopFromInteractive hsc_env (edge:edges) cached_nodes = case edge of Left edge -> do (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes return (edge : edges, cached_nodes') Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) let k _ loc mod = let key = moduleToMnk mod is_boot in return $ FoundHome (ModuleNodeFixed key loc) found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] case found of -- Case 1: Home modules have to already be in the cache. FoundHome (ModuleNodeFixed mod _) -> do let edge = ModuleNodeEdge lvl (NodeKey_Module mod) -- Note: Does not perform any further downsweep as the module must already be in the cache. (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes return (edge : edges, cached_nodes') -- Case 2: External units may not be in the cache, if we haven't already initialised the -- module graph. We can construct the module graph for those here by calling loopUnit. External uid -> do let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env cached_nodes' = loopUnit hsc_env' cached_nodes [uid] edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes' return (edge : edges, cached_nodes') -- And if it's not found.. just carry on and hope. _ -> loopFromInteractive hsc_env edges cached_nodes -- | Create a module graph from a list of installed modules. -- This is used by the loader when we need to load modules but there -- isn't already an existing module graph. For example, when loading plugins -- during initialisation. -- -- If you call this function, then if the `Module` you request to downsweep can't -- be found then this function will throw errors. -- If you need to use this function elsewhere, then it would make sense to make it -- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit. -- At the moment, it is overfitted for what `get_reachable_nodes` needs. downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph downsweepInstalledModules hsc_env mods = do let (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods installed_mods = map (fst . getModuleInstantiation) home_mods external_uids = map moduleUnitId external_mods process :: InstalledModule -> IO ModuleNodeInfo process i = do res <- findExactModule hsc_env i NotBoot case res of InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc -- It is an internal-ish error if this happens, since we any call to this function should -- already know that we can find the modules we need to load. _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i nodes <- mapM process installed_mods (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids -- Similarly here, we should really not get any errors, but print them out if we do. let dflags = hsc_dflags hsc_env liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) (initPrintConfig dflags) (initDiagOpts dflags) (GhcDriverMessage <$> unionManyMessages errs) return (mkModuleGraph mg) -- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used -- by --make mode, and fixed nodes by oneshot mode. -- -- See Note [Module Types in the ModuleGraph] for the difference between the two. data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed -- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root -- 'UnitId's. -- This function will start at the given roots, and traverse downwards to find -- all the dependencies, all the way to the leaf units. downsweepFromRootNodes :: HscEnv -> M.Map (UnitId, FilePath) ModSummary -> [ModuleName] -> Bool -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo -> [UnitId] -- ^ The starting units -> IO ([DriverMessages], [ModuleGraphNode]) downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids = do let root_map = mkRootMap root_nodes checkDuplicates root_map let env = DownsweepEnv hsc_env mode old_summaries excl_mods (deps', map0) <- runDownsweepM env $ do (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) let all_deps = loopUnit hsc_env module_deps root_uids let all_instantiations = getHomeUnitInstantiations hsc_env deps' <- loopInstantiations all_instantiations all_deps return (deps', map0) let downsweep_errs = lefts $ concat $ M.elems map0 downsweep_nodes = M.elems deps' return (downsweep_errs, downsweep_nodes) where getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) -- In a root module, the filename is allowed to diverge from the module -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently -- ignored, leading to confusing behaviour). checkDuplicates :: DownsweepCache -> IO () checkDuplicates root_map | not allow_dup_roots , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root | otherwise = pure () where dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights (M.elems root_map) calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] calcDeps ms = -- Add a dependency on the HsBoot file if it exists -- This gets passed to the loopImports function which just ignores it if it -- can't be found. [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ] type DownsweepM a = ReaderT DownsweepEnv IO a data DownsweepEnv = DownsweepEnv { downsweep_hsc_env :: HscEnv , _downsweep_mode :: DownsweepMode , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary , _downsweep_excl_mods :: [ModuleName] } runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a runDownsweepM env act = runReaderT act env loopInstantiations :: [(UnitId, InstantiatedUnit)] -> M.Map NodeKey ModuleGraphNode -> DownsweepM (M.Map NodeKey ModuleGraphNode) loopInstantiations [] done = pure done loopInstantiations ((home_uid, iud) :xs) done = do hsc_env <- asks downsweep_hsc_env let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env done' = loopUnit hsc_env' done [instUnitInstanceOf iud] payload = InstantiationNode home_uid iud loopInstantiations xs (M.insert (mkNodeKey payload) payload done') -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit loopSummaries :: [ModSummary] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache) loopSummaries [] done = pure done loopSummaries (ms:next) (done, summarised) | Just {} <- M.lookup k done = loopSummaries next (done, summarised) -- Didn't work out what the imports mean yet, now do that. | otherwise = do (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') where k = NodeKey_Module (msKey ms) hs_file_for_boot | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) | otherwise = Nothing loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) loopModuleNodeInfo mod_node_info (done, summarised) = do case mod_node_info of ModuleNodeCompile ms -> do loopSummaries [ms] (done, summarised) ModuleNodeFixed mod ml -> do done' <- loopFixedModule mod ml done return (done', summarised) -- NB: loopFixedModule does not take a downsweep cache, because if you -- ever reach a Fixed node, everything under that also must be fixed. loopFixedModule :: ModNodeKeyWithUid -> ModLocation -> M.Map NodeKey ModuleGraphNode -> DownsweepM (M.Map NodeKey ModuleGraphNode) loopFixedModule key loc done = do let nk = NodeKey_Module key hsc_env <- asks downsweep_hsc_env case M.lookup nk done of Just {} -> return done Nothing -> do -- MP: TODO, we should just read the dependency info from the interface rather than either -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) read_result <- liftIO $ -- 1. Check if the interface is already loaded into the EPS by some other -- part of the compiler. lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case Just iface -> return (M.Succeeded iface) Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) case read_result of M.Succeeded iface -> do -- Computer information about this node let node_deps = ifaceDeps (mi_deps iface) edges = map mkFixedEdge node_deps node = ModuleNode edges (ModuleNodeFixed key loc) foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps) -- Ignore any failure, we might try to read a .hi-boot file for -- example, even if there is not one. M.Failed {} -> return done loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode) loopFixedNodeKey _ done (Left key) = do loopFixedImports [key] done loopFixedNodeKey home_uid done (Right uid) = do -- Set active unit so that looking loopUnit finds the correct -- -package flags in the unit state. hsc_env <- asks downsweep_hsc_env let hsc_env' = hscSetActiveUnitId home_uid hsc_env return $ loopUnit hsc_env' done [uid] mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] ifaceDeps deps = [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) ] ++ [ Right (tcImportLevel lvl, uid) | (lvl, uid) <- Set.toList (dep_direct_pkgs deps) ] -- Like loopImports, but we already know exactly which module we are looking for. loopFixedImports :: [ModNodeKeyWithUid] -> M.Map NodeKey ModuleGraphNode -> DownsweepM (M.Map NodeKey ModuleGraphNode) loopFixedImports [] done = pure done loopFixedImports (key:keys) done = do let nk = NodeKey_Module key hsc_env <- asks downsweep_hsc_env case M.lookup nk done of Just {} -> loopFixedImports keys done Nothing -> do read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) case read_result of InstalledFound loc -> do done' <- loopFixedModule key loc done loopFixedImports keys done' _otherwise -> -- If the finder fails, just keep going, there will be another -- error later. loopFixedImports keys done downsweepSummarise :: HomeUnit -> IsBootInterface -> Located ModuleName -> PkgQual -> Maybe (StringBuffer, UTCTime) -> DownsweepM SummariseResult downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do DownsweepEnv hsc_env mode old_summaries excl_mods <- ask case mode of DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover -- a new module by doing this. loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] -- Work list: process these modules -> M.Map NodeKey ModuleGraphNode -> DownsweepCache -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True -> DownsweepM ([ModuleNodeEdge], M.Map NodeKey ModuleGraphNode, DownsweepCache) -- The result is the completed NodeMap loopImports [] done summarised = return ([], done, summarised) loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised | Just summs <- M.lookup cache_key summarised = case summs of [Right ms] -> do let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms)) (rest, summarised', done') <- loopImports ss done summarised return (nk: rest, summarised', done') [Left _err] -> loopImports ss done summarised _errs -> do loopImports ss done summarised | otherwise = do hsc_env <- asks downsweep_hsc_env let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing case mb_s of NotThere -> loopImports ss done summarised External uid -> do -- Pass an updated hsc_env to loopUnit, as each unit might -- have a different visible package database. let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env let done' = loopUnit hsc_env' done [uid] (other_deps, done'', summarised') <- loopImports ss done' summarised return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') FoundInstantiation iud -> do (other_deps, done', summarised') <- loopImports ss done summarised return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) FoundHome s -> do (done', summarised') <- loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised) (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised) where cache_key = (home_uid, mb_pkg, unLoc <$> gwib) GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib wanted_mod = L loc mod loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode loopUnit _ cache [] = cache loopUnit lcl_hsc_env cache (u:uxs) = do let nk = (NodeKey_ExternalUnit u) case Map.lookup nk cache of Just {} -> loopUnit lcl_hsc_env cache uxs Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u) multiRootsErr :: [ModuleNodeInfo] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) = throwOneError $ fmap GhcDriverMessage $ mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files where mod = moduleNodeInfoModule summ1 files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod) -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. -- These are used to represent the type checking that is done after -- all the free holes (sigs in current package) relevant to that instantiation -- are compiled. This is necessary to catch some instantiation errors. instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)] instantiationNodes uid unit_state = map (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 ] -- The linking plan for each module. If we need to do linking for a home unit -- then this function returns a graph node which depends on all the modules in the home unit. -- At the moment nothing can depend on these LinkNodes. 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) . mgNodeUnitId) summaries) -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. -- We attempt linking if either (a) one of the modules is -- called Main, or (b) the user said -no-hs-main, indicating -- that main() is going to come from somewhere else. -- 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)) -- This should be an error, not a warning (#10895). | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid)) | otherwise -> Nothing getRootSummary :: [ModuleName] -> M.Map (UnitId, FilePath) ModSummary -> HscEnv -> Target -> IO (Either DriverMessages ModSummary) getRootSummary excl_mods old_summary_map hsc_env target | TargetFile file mb_phase <- targetId = do let offset_file = augmentByWorkingDirectory dflags file exists <- liftIO $ doesFileExist offset_file if exists || isJust maybe_buf then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase maybe_buf else return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) | TargetModule modl <- targetId = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) maybe_buf excl_mods pure case maybe_summary of FoundHome (ModuleNodeCompile s) -> Right s FoundHomeWithError err -> Left (snd err) _ -> Left (moduleNotFoundErr uid modl) where Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) rootLoc = mkGeneralSrcSpan (fsLit "") dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)) -- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline -- system. -- Create bundles of 'Target's wrapped in a 'MakeAction' that uses -- 'withAbstractSem' to wait for a free slot, limiting the number of -- concurrently computed summaries to the value of the @-j@ option or the slots -- allocated by the job server, if that is used. -- -- The 'MakeAction' returns 'Maybe', which is not handled as an error, because -- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the -- result won't be read anyway here. -- -- To emulate the current behavior, we funnel exceptions past the concurrency -- barrier and rethrow the first one afterwards. rootSummariesParallel :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) -> IO ([DriverMessages], [ModSummary]) rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles) runPipelines n_jobs hsc_env diag_wrapper msg actions (sequence . catMaybes <$> sequence get_results) >>= \case Right results -> pure (partitionEithers (concat results)) Left exc -> throwIO exc where bundles = mk_bundles targets mk_bundles = unfoldr \case [] -> Nothing ts -> Just (splitAt bundle_size ts) bundle_size = 20 targets = hsc_targets hsc_env action_and_result (log_queue_id, ts) = do res_var <- liftIO newEmptyMVar pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var) action log_queue_id target_bundle = do env@MakeEnv {compile_sem} <- ask lift $ lift $ withAbstractSem compile_sem $ withLoggerHsc log_queue_id env \ lcl_hsc_env -> MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case Left e | Just (_ :: SomeAsyncException) <- fromException e -> throwIO e a -> pure a -- | This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -- -- See Note [Multiple Home Units], section 'Closure Property'. checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] checkHomeUnitsClosed ue | Set.null bad_unit_ids = [] | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] where home_id_set = HUG.allUnits $ ue_home_unit_graph ue bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -} rootLoc = mkGeneralSrcSpan (fsLit "") downwards_closure :: Graph (Node UnitId UnitId) downwards_closure = graphFromEdgedVerticesUniq graphNodes inverse_closure = graphReachability $ transposeG downwards_closure upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) all_unit_direct_deps = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue where go rest this this_uis = plusUniqMap_C Set.union (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) rest where external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units) this_units = homeUnitEnv_units this_uis this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] graphNodes :: [Node UnitId UnitId] graphNodes = go Set.empty home_id_set where go done todo = case Set.minView todo of Nothing -> [] Just (uid, todo') | Set.member uid done -> go done todo' | otherwise -> case lookupUniqMap all_unit_direct_deps uid of Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) Just depends -> let todo'' = (depends Set.\\ done) `Set.union` todo' in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to -- the specified target, disable optimization and change the .hi -- and .o file locations to be temporary files. -- See Note [-fno-code mode] enableCodeGenForTH :: Logger -> TmpFs -> UnitEnv -> [ModuleGraphNode] -> IO ModuleGraph enableCodeGenForTH logger tmpfs unit_env = enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord) instance Outputable CodeGenEnable where ppr = text . show -- | Helper used to implement 'enableCodeGenForTH'. -- In particular, this enables -- unoptimized code generation for all modules that meet some -- condition (first parameter), or are dependencies of those -- modules. The second parameter is a condition to check before -- marking modules for code generation. enableCodeGenWhen :: Logger -> TmpFs -> TempFileLifetime -> TempFileLifetime -> UnitEnv -> [ModuleGraphNode] -> IO ModuleGraph enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do mgMapM enable_code_gen mg where defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env) enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo enable_code_gen (ModuleNodeCompile ms) = ModuleNodeCompile <$> enable_code_gen_ms ms enable_code_gen m@(ModuleNodeFixed {}) = return m -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`. -- It would be good to consider how to make these checks more uniform and not duplicated. enable_code_gen_ms :: ModSummary -> IO ModSummary enable_code_gen_ms ms | ModSummary { ms_location = ms_location , ms_hsc_src = HsSrcFile , ms_hspp_opts = dflags } <- ms , Just enable_spec <- needs_codegen_map ms = 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 (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn) -- We don't want to create .o or .hi files unless we have been asked -- to by the user. But we need them, so we patch their locations in -- the ModSummary with temporary files. -- ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <- -- If ``-fwrite-interface` is specified, then the .o and .hi files -- are written into `-odir` and `-hidir` respectively. #16670 if gopt Opt_WriteInterface dflags then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location) , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location)) else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags)) <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags)) let new_dflags = case enable_spec of EnableByteCode -> dflags { backend = interpreterBackend } EnableObject -> dflags { backend = defaultBackendOf ms } EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms} let ms' = ms { ms_location = ms_location { ml_hi_file_ospath = hi_file , ml_obj_file_ospath = o_file , ml_dyn_hi_file_ospath = dyn_hi_file , ml_dyn_obj_file_ospath = dyn_o_file } , ms_hspp_opts = updOptLevel 0 $ new_dflags } -- Recursive call to catch the other cases enable_code_gen_ms ms' -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough) -- we only get to this case if the default backend is already generating object files, but we need dynamic -- objects | bytecode_and_enable enable_spec ms -> do let ms' = ms { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode } -- Recursive call to catch the other cases enable_code_gen_ms ms' | dynamic_too_enable enable_spec ms -> do let ms' = ms { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo } -- Recursive call to catch the other cases enable_code_gen_ms ms' | ext_interp_enable ms -> do let ms' = ms { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter } -- Recursive call to catch the other cases enable_code_gen_ms ms' | needs_full_ways dflags -> do let ms' = ms { ms_hspp_opts = set_full_ways dflags } -- Recursive call to catch the other cases enable_code_gen_ms ms' | otherwise -> return ms enable_code_gen_ms ms = return ms nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) = not (backendGeneratesCode (backend dflags)) && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219. isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) bytecode_and_enable enable_spec ms = -- In the situation where we **would** need to enable dynamic-too -- IF we had decided we needed objects dynamic_too_enable EnableObject ms -- but we prefer to use bytecode rather than objects && prefer_bytecode -- and we haven't already turned it on && not generate_both where lcl_dflags = ms_hspp_opts ms prefer_bytecode = case enable_spec of EnableByteCodeAndObject -> True EnableByteCode -> True EnableObject -> False generate_both = gopt Opt_ByteCodeAndObjectCode lcl_dflags -- #8180 - when using TemplateHaskell, switch on -dynamic-too so -- the linker can correctly load the object files. This isn't necessary -- when using -fexternal-interpreter. -- FIXME: Duplicated from makeDynFlagsConsistent dynamic_too_enable enable_spec ms | sTargetRTSLinkerOnlySupportsSharedLibs $ settings lcl_dflags = not isDynWay && not dyn_too_enabled && enable_object | otherwise = hostIsDynamic && not hostIsProfiled && internalInterpreter && not isDynWay && not isProfWay && not dyn_too_enabled && enable_object 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 enable_object = case enable_spec of EnableByteCode -> False EnableByteCodeAndObject -> True EnableObject -> True -- #16331 - when no "internal interpreter" is available but we -- need to process some TemplateHaskell or QuasiQuotes, we automatically -- turn on -fexternal-interpreter. ext_interp_enable ms = not ghciSupported && internalInterpreter where lcl_dflags = ms_hspp_opts ms internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) mg = mkModuleGraph mod_graph (td_map, lookup_node) = mkStageDeps mod_graph queryReachable ns = isReachableMany td_map (mapMaybe lookup_node ns) -- NB: Do not inline these, it is very important to share them across all calls -- to needs_obj_set and needs_bc_set. !query_obj = let !deps = queryReachable need_obj_set in \k -> deps (expectJust $ lookup_node k) !query_bc = let !deps = queryReachable need_bc_set in \k -> deps (expectJust $ lookup_node k) -- The direct dependencies of modules which require object code need_obj_set = -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only -- it's dependencies. [ (mkNodeKey m, RunStage) | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph , isTemplateHaskellOrQQNonBoot ms , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)) ] -- The direct dependencies of modules which require byte code need_bc_set = [ (mkNodeKey m, RunStage) | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph , isTemplateHaskellOrQQNonBoot ms , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms) ] needs_obj_set, needs_bc_set :: ModNodeKeyWithUid -> Bool needs_obj_set k = query_obj (NodeKey_Module k, CompileStage) needs_bc_set k = query_bc (NodeKey_Module k, CompileStage) -- A map which tells us how to enable code generation for a NodeKey needs_codegen_map :: ModSummary -> Maybe CodeGenEnable needs_codegen_map ms = let nk = msKey ms -- Another option here would be to just produce object code, rather than both object and -- byte code in case (needs_obj_set nk, needs_bc_set nk) of (True, True) -> Just EnableByteCodeAndObject (True, False) -> Just EnableObject (False, True) -> Just EnableByteCode (False, False) -> Nothing -- FIXME: Duplicated from makeDynFlagsConsistent needs_full_ways dflags = ghcLink dflags == LinkInMemory && not (gopt Opt_ExternalInterpreter dflags) && targetWays_ dflags /= hostFullWays set_full_ways dflags = let platform = targetPlatform dflags dflags_a = dflags { targetWays_ = hostFullWays } dflags_b = foldl gopt_set dflags_a $ concatMap (wayGeneralFlags platform) hostFullWays dflags_c = foldl gopt_unset dflags_b $ concatMap (wayUnsetGeneralFlags platform) hostFullWays in dflags_c {- Note [-fno-code mode] ~~~~~~~~~~~~~~~~~~~~~~~~ GHC offers the flag -fno-code for the purpose of parsing and typechecking a program without generating object files. This is intended to be used by tooling and IDEs to provide quick feedback on any parser or type errors as cheaply as possible. When GHC is invoked with -fno-code, no object files or linked output will be generated. As many errors and warnings as possible will be generated, as if -fno-code had not been passed. The session DynFlags will have backend == NoBackend. -fwrite-interface ~~~~~~~~~~~~~~~~ Whether interface files are generated in -fno-code mode is controlled by the -fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is not also passed. Recompilation avoidance requires interface files, so passing -fno-code without -fwrite-interface should be avoided. If -fno-code were re-implemented today, there would be no need for -fwrite-interface as it would considered always on; this behaviour is as it is for backwards compatibility. ================================================================ IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER ================================================================ Template Haskell ~~~~~~~~~~~~~~~~ A module using Template Haskell may invoke an imported function from inside a splice. This will cause the type-checker to attempt to execute that code, which would fail if no object files had been generated. See #8025. To rectify this, during the downsweep we patch the DynFlags in the ModSummary of any home module that is imported by a module that uses Template Haskell to generate object code. The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled or not in the module which needs the code generation. If the module requires byte-code then dependencies will generate byte-code, otherwise they will generate object files. In the case where some modules require byte-code and some object files, both are generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these configurations. The object files (and interface files if -fwrite-interface is disabled) produced for Template Haskell are written to temporary files. Note that since Template Haskell can run arbitrary IO actions, -fno-code mode is no more secure than running without it. Explicit Level Imports ~~~~~~~~~~~~~~~~~~~~~~ When `-XExplicitLevelImports` is enabled, code is only generated for modules needed for the compile stage. The ReachabilityIndex created by `mkStageDeps` answers the question, if I compile a module for a specific stage, then which modules at other stages do I need. The roots of this query are the modules which use `TemplateHaskell` at the runtime stage, and modules we need code generation for are those which are needed at the compile time stage. All the logic about how ExplicitLevelImports and TemplateHaskell affect the needed stages of a module is encoded in mkStageDeps. Potential TODOS: ~~~~~ * Remove -fwrite-interface and have interface files always written in -fno-code mode * Both .o and .dyn_o files are generated for template haskell, but we only need .dyn_o (for dynamically linked compilers) Fix it. (The needed way is 'hostFullWays') * In make mode, a message like Compiling A (A.hs, /tmp/ghc_123.o) is shown if downsweep enabled object code generation for A. Perhaps we should show "nothing" or "temporary object file" instead. Note that one can currently use -keep-tmp-files and inspect the generated file with the current behaviour. * Offer a -no-codedir command line option, and write what were temporary object files there. This would speed up recompilation. * Use existing object files (if they are up to date) instead of always generating temporary ones. -} -- | Populate the Downsweep cache with the root modules. mkRootMap :: [ModuleNodeInfo] -> DownsweepCache mkRootMap summaries = Map.fromListWith (flip (++)) [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ] ----------------------------------------------------------------------------- -- Summarising modules -- We have two types of summarisation: -- -- * Summarise a file. This is used for the root module(s) passed to -- cmLoadModules. The file is read, and used to determine the root -- module name. The module name may differ from the filename. -- -- * Summarise a module. We are given a module name, and must provide -- a summary. The finder is used to locate the file in which the module -- resides. summariseFile :: HscEnv -> HomeUnit -> M.Map (UnitId, FilePath) ModSummary -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) -> IO (Either DriverMessages ModSummary) summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries = do let location = ms_location $ old_summary src_hash <- get_src_hash -- The file exists; we checked in getRootSummary above. -- If it gets removed subsequently, then this -- getFileHash may fail, but that's the right -- behaviour. -- return the cached summary if the source didn't change 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 -- change the main active unit so all operations happen relative to the given unit hsc_env = hscSetActiveHomeUnit home_unit hsc_env' -- src_fn does not necessarily exist on the filesystem, so we need to -- check what kind of target we are dealing with 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) (basename, extension) = splitExtension src_fn hsc_src | isHaskellSigSuffix (drop 1 extension) = HsigFile | isHaskellBootSuffix (drop 1 extension) = HsBootFile | otherwise = HsSrcFile -- Make a ModLocation for this file, adding the @-boot@ suffix to -- all paths if the original was a boot file. location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path 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 hsc_src liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary { nms_src_fn = src_fn , nms_src_hash = src_hash , nms_hsc_src = hsc_src , 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 -- update the object-file timestamp obj_timestamp <- modificationTimeIfExists (ml_obj_file location) -- We have to repopulate the Finder's cache for file targets -- because the file might not even be on the regular search path -- and it was likely flushed in depanal. This is not technically -- needed when we're called from sumariseModule but it shouldn't -- hurt. let fc = hsc_FC hsc_env mod = ms_mod old_summary hsc_src = ms_hsc_src old_summary addModuleToFinder fc mod location hsc_src 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 = -- source changed: re-summarise. new_summary src_hash data SummariseResult = FoundInstantiation InstantiatedUnit | FoundHomeWithError (UnitId, DriverMessages) | FoundHome ModuleNodeInfo | External UnitId | NotThere -- | summariseModule finds the location of the source file for the given module. -- This version always returns a ModuleNodeCompile node, it is useful for -- --make mode. summariseModule :: HscEnv -> HomeUnit -> M.Map (UnitId, FilePath) ModSummary -> IsBootInterface -> Located ModuleName -> PkgQual -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -> IO SummariseResult summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods where k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf -- | Like summariseModule but for interface files that we don't want to compile. -- This version always returns a ModuleNodeFixed node. summariseModuleInterface :: HscEnv -> HomeUnit -> IsBootInterface -> Located ModuleName -> PkgQual -> [ModuleName] -> IO SummariseResult summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods where k _hsc_env loc mod = do -- The finder will return a path to the .hi-boot even if it doesn't actually -- exist. So check if it exists first before concluding it's there. does_exist <- doesFileExist (ml_hi_file loc) if does_exist then let key = moduleToMnk mod is_boot in return $ FoundHome (ModuleNodeFixed key loc) else return NotThere -- Summarise a module, and pick up source and timestamp. summariseModuleDispatch :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module. -> HscEnv -> HomeUnit -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised -> PkgQual -> [ModuleName] -- Modules to exclude -> IO SummariseResult summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods | wanted_mod `elem` excl_mods = return NotThere | otherwise = find_it where -- Temporarily change the currently active home unit so all operations -- happen relative to it hsc_env = hscSetActiveHomeUnit home_unit hsc_env' find_it :: IO SummariseResult find_it = do found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg case found of Found location mod | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> -- Home package k hsc_env location mod | VirtUnit iud <- moduleUnit mod , not (isHomeModule home_unit mod) -> return $ FoundInstantiation iud | otherwise -> return $ External (moduleUnitId mod) _ -> return NotThere -- Not found -- (If it is TRULY not found at all, we'll -- error when we actually try to compile) -- | The continuation to summarise a home module if we want to find the source file -- for it and potentially compile it. summariseModuleWithSource :: HomeUnit -> M.Map (UnitId, FilePath) ModSummary -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Maybe (StringBuffer, UTCTime) -> HscEnv -> ModLocation -> Module -> IO SummariseResult summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do -- Adjust location to point to the hs-boot source file, -- hi file, object file, when is_boot says so let src_fn = expectJust (ml_hs_file location) -- Check that it exists -- It might have been deleted since the Finder last found it maybe_h <- fileHashIfExists src_fn case maybe_h of -- This situation can also happen if we have found the .hs file but the -- .hs-boot file doesn't exist. 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 (ModuleNodeCompile ms) where dflags = hsc_dflags hsc_env new_summary_cache_check loc mod src_fn h | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = -- check the hash on the source file, and -- return the cached summary if it hasn't changed. If the -- file has changed then need to resummarise. 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 {..} -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP -- See multiHomeUnits_cpp2 test <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf -- NB: Despite the fact that is_boot is a top-level parameter, we -- don't actually know coming into this function what the HscSource -- of the module in question is. This is because we may be processing -- this module because another module in the graph imported it: in this -- case, we know if it's a boot or not because of the {-# SOURCE #-} -- annotation, but we don't know if it's a signature or a regular -- module until we actually look it up on the filesystem. let hsc_src | is_boot == IsBoot = HsBootFile | isHaskellSigFilename src_fn = HsigFile | otherwise = HsSrcFile when (pi_mod_name /= moduleName mod) $ throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ DriverFileModuleNameMismatch pi_mod_name (moduleName 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_hsc_src = hsc_src , nms_location = location , nms_mod = mod , nms_preimps = preimps } -- | Convenience named arguments for 'makeNewModSummary' only used to make -- code more readable, not exported. data MakeNewModSummary = MakeNewModSummary { nms_src_fn :: FilePath , nms_src_hash :: Fingerprint , 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_textual_imps = ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) ++ ((,,) NormalLevel 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 :: [Located ModuleName] , pi_theimps :: [(ImportLevel, PkgQual, Located ModuleName)] , pi_hspp_fn :: FilePath , pi_hspp_buf :: StringBuffer , pi_mod_name_loc :: SrcSpan , pi_mod_name :: ModuleName } -- Preprocess the source file and get its imports -- The pi_local_dflags contains the OPTIONS pragmas getPreprocessedImports :: HscEnv -> FilePath -> Maybe Phase -> Maybe (StringBuffer, UTCTime) -- ^ optional source code buffer and modification time -> ExceptT 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', 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 (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn)) let pi_srcimps = pi_srcimps' let pi_theimps = rn_imps pi_theimps' return PreprocessedImports {..}