Torsten Schmits pushed to branch wip/torsten.schmits/mwb-26-01/fixed at Glasgow Haskell Compiler / GHC Commits: fe5932d4 by Torsten Schmits at 2026-04-22T02:29:34+02:00 Avoid expensive computation for debug logging in `mergeDatabases` when log level is low - - - - - 630ee987 by Torsten Schmits at 2026-04-22T02:30:10+02:00 Fixed nodes - - - - - 10 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - utils/haddock Changes: ===================================== compiler/GHC.hs ===================================== @@ -75,9 +75,12 @@ module GHC ( compileToCoreModule, compileToCoreSimplified, -- * Inspecting the module structure of the program - ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, - mgLookupModule, + ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, mgModSummaries', + mgLookupModule, mgNodeIsModule, ModSummary(..), ms_mod_name, ModLocation(..), + ModuleNodeInfo(..), moduleNodeInfoModule, moduleNodeInfoModuleName, + moduleNodeInfoLocation, moduleNodeInfoHscSource, + isBootModuleNodeInfo, pattern ModLocation, getModSummary, getModuleGraph, ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -748,9 +748,9 @@ hsunitModuleGraph do_link unit = do -- create an "empty" hsig file to induce compilation for the -- requirement. let hsig_set = Set.fromList - [ ms_mod_name ms + [ moduleNodeInfoModuleName ms | ModuleNode _ ms <- nodes - , ms_hsc_src ms == HsigFile + , moduleNodeInfoHscSource ms == Just HsigFile ] req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> if Set.member mod_name hsig_set @@ -825,7 +825,7 @@ summariseRequirement pn mod_name = do ms_hspp_buf = Nothing } let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ] - return (ModuleNode nodes ms) + return (ModuleNode nodes (ModuleNodeCompile ms)) summariseDecl :: PackageName -> HscSource @@ -943,7 +943,7 @@ hsModuleToModSummary home_keys pn hsc_src modname [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys] - return (ModuleNode (mod_nodes ++ inst_nodes) ms) + return (ModuleNode (mod_nodes ++ inst_nodes) (ModuleNodeCompile ms)) -- | Create a new, externally provided hashed unit id from -- a hash. ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -50,6 +50,7 @@ module GHC.Driver.Main , initModDetails , initWholeCoreBindings , loadIfaceByteCode + , loadIfaceByteCodeLazy , hscMaybeWriteIface , hscCompileCmmFile @@ -106,6 +107,7 @@ module GHC.Driver.Main , hscAddSptEntries , writeInterfaceOnlyMode , loadByteCode + , genModDetails ) where import GHC.Prelude @@ -824,7 +826,7 @@ hscRecompStatus = do let msg what = case mHscMessage of - Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary) + Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] (ModuleNodeCompile mod_summary)) Nothing -> return () -- First check to see if the interface file agrees with the @@ -1055,6 +1057,27 @@ loadIfaceByteCode hsc_env iface location type_env = time <- maybe getCurrentTime pure if_time return $! Linkable time (mi_module iface) parts +loadIfaceByteCodeLazy :: + HscEnv -> + ModIface -> + ModLocation -> + TypeEnv -> + IO (Maybe Linkable) +loadIfaceByteCodeLazy hsc_env iface location type_env = + case iface_core_bindings iface location of + Nothing -> return Nothing + Just wcb -> do + Just <$> compile wcb + where + compile decls = do + ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls + linkable $ BCOs bcos :| [DotO fo ForeignObject | fo <- fos] + + linkable parts = do + if_time <- modificationTimeIfExists (ml_hi_file location) + time <- maybe getCurrentTime pure if_time + return $!Linkable time (mi_module iface) parts + -- | If the 'Linkable' contains Core bindings loaded from an interface, replace -- them with a lazy IO thunk that compiles them to bytecode and foreign objects, -- using the supplied environment for type checking. ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -43,115 +43,108 @@ module GHC.Driver.Make ( ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith ) where -import GHC.Prelude -import GHC.Platform - -import GHC.Tc.Utils.Backpack -import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM ) - -import GHC.Runtime.Interpreter -import qualified GHC.Linker.Loader as Linker -import GHC.Linker.Types - -import GHC.Platform.Ways - -import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Driver.Config.Parser (initParserOpts) -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Phases -import GHC.Driver.Pipeline -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Monad -import GHC.Driver.Env -import GHC.Driver.Errors -import GHC.Driver.Errors.Types -import GHC.Driver.Main -import GHC.Driver.MakeSem - -import GHC.Parser.Header +import Control.Concurrent ( + ThreadId, + forkIOWithUnmask, + killThread, + newQSem, + signalQSem, + waitQSem, + ) +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Monad +import qualified Control.Monad.Catch as MC +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Lazy +import Data.Bifunctor (first) +import Data.Either (lefts, partitionEithers, rights) +import Data.Function +import Data.IORef +import Data.List (groupBy, sortBy, sortOn, unfoldr) +import qualified Data.Map as Map +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Set as Set +import Data.Time import GHC.ByteCode.Types - -import GHC.Iface.Load ( cannotFindModule ) -import GHC.IfaceToCore ( typecheckIface ) -import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) ) - -import GHC.Data.Bag ( listToBag ) -import GHC.Data.Graph.Directed +import qualified GHC.Conc as CC +import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities) +import GHC.Data.Bag (listToBag) import GHC.Data.FastString -import GHC.Data.Maybe ( expectJust ) -import GHC.Data.OsPath ( unsafeEncodeUtf ) +import GHC.Data.Graph.Directed +import GHC.Data.Graph.Directed.Reachability +import qualified GHC.Data.Maybe as MB +import GHC.Data.Maybe (expectJust) +import qualified GHC.Data.OsPath as OsPath +import GHC.Data.OsPath (OsPath, unsafeEncodeUtf) import GHC.Data.StringBuffer +import GHC.Iface.Errors.Types +import GHC.Iface.Load (cannotFindModule, readIface) +import GHC.Iface.Recomp (CompileReason (..), RecompileRequired (..)) +import GHC.IfaceToCore (typecheckIface) 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 qualified GHC.Linker.Loader as Linker +import GHC.Linker.Types +import GHC.Parser.Header +import GHC.Platform +import GHC.Platform.Ways +import GHC.Prelude +import GHC.Rename.Names +import GHC.Runtime.Interpreter +import GHC.Runtime.Loader +import GHC.Tc.Utils.Backpack +import GHC.Tc.Utils.Monad (concatMapM, initIfaceCheck) import GHC.Types.Basic import GHC.Types.Error -import GHC.Types.Target -import GHC.Types.SourceFile +import GHC.Types.PkgQual import GHC.Types.SourceError +import GHC.Types.SourceFile import GHC.Types.SrcLoc +import GHC.Types.Target +import GHC.Types.TypeEnv import GHC.Types.Unique.Map -import GHC.Types.PkgQual - import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Graph +import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable +import GHC.Unit.Module.Graph import GHC.Unit.Module.ModDetails - -import Data.Either ( rights, partitionEithers, lefts ) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import GHC.Data.OsPath (OsPath) -import qualified GHC.Data.OsPath as OsPath -import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) -import qualified GHC.Conc as CC -import Control.Concurrent.MVar -import Control.Monad -import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) -import qualified Control.Monad.Catch as MC -import Data.IORef -import Data.Maybe -import Data.Time -import Data.List (sortOn, unfoldr) -import Data.List (sortOn, unfoldr, groupBy, sortBy) -import Data.Bifunctor (first) +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Utils.Constants +import GHC.Utils.Error +import GHC.Utils.Exception (SomeAsyncException, throwIO) +import GHC.Utils.Fingerprint +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.TmpFs import System.Directory import System.FilePath -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.Backend +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Finder (initFinderOpts) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Env import GHC.Driver.Env.KnotVars -import Control.Concurrent.STM -import Control.Monad.Trans.Maybe -import GHC.Runtime.Loader -import GHC.Rename.Names -import GHC.Utils.Constants -import GHC.Iface.Errors.Types -import Data.Function - -import GHC.Data.Graph.Directed.Reachability -import qualified GHC.Unit.Home.Graph as HUG -import GHC.Unit.Home.PackageTable +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.Driver.MakeSem +import GHC.Driver.Monad +import GHC.Driver.Phases +import GHC.Driver.Pipeline +import GHC.Driver.Pipeline.LogQueue +import GHC.Driver.Session -- ----------------------------------------------------------------------------- -- Loading the program @@ -628,13 +621,16 @@ createBuildPlan mod_graph maybe_top_mod = -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists 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] + [ (mn, (m, boot_path (moduleName mn) (moduleUnitId mn))) + | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph) + , let mn = moduleNodeInfoModule ms + , isBootModuleNodeInfo 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 + get_boot_module m = case m of ModuleNode _ ms | NotBoot <- isBootModuleNodeInfo ms -> lookupModuleEnv boot_modules (moduleNodeInfoModule ms); _ -> Nothing -- Any cycles should be resolved now collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] @@ -760,7 +756,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- prune the HPT so everything is not retained when doing an -- upsweep. !pruned_cache = pruneCache cache - (flattenSCCs (filterToposortToModules mg2_with_srcimps)) + [ms | (ModuleNodeCompile ms) <- (flattenSCCs (filterToposortToModules mg2_with_srcimps))] -- before we unload anything, make sure we don't leave an old @@ -820,7 +816,7 @@ guessOutputFile = modifySession $ \env -> mainModuleSrcPath :: Maybe String mainModuleSrcPath = do ms <- mgLookupModule mod_graph (mainModIs hue) - ml_hs_file (ms_location ms) + ml_hs_file (moduleNodeInfoLocation ms) name = fmap dropExtension mainModuleSrcPath -- MP: This exception is quite sensitive to being forced, if you @@ -1153,7 +1149,7 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do executeInstantiationNode mod_idx n_mods hug uid iu return Nothing ModuleNode _build_deps ms -> - let !old_hmi = M.lookup (msKey ms) old_hpt + let !old_hmi = M.lookup (mnKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes in withCurrentUnit (moduleGraphNodeUnitId mod) $ do !_ <- wait_deps build_deps @@ -1523,13 +1519,13 @@ modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f -- components in the topological sort, then those imports can -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE -- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModuleNodeInfo] -> 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, + let mods_in_this_cycle = map moduleNodeInfoModuleName ms in + [ warn i | (ModuleNodeCompile m) <- ms, i <- ms_home_srcimps m, unLoc i `notElem` mods_in_this_cycle ] warn :: Located ModuleName -> MsgEnvelope GhcMessage @@ -1670,7 +1666,7 @@ downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (roo (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 ms) done'', summarised'') + loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') where k = NodeKey_Module (msKey ms) @@ -1904,7 +1900,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env 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) + enable_code_gen n@(ModuleNode deps (ModuleNodeCompile ms)) | ModSummary { ms_location = ms_location , ms_hsc_src = HsSrcFile @@ -1942,7 +1938,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = , ms_hspp_opts = updOptLevel 0 $ new_dflags } -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') + enable_code_gen (ModuleNode deps (ModuleNodeCompile 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 @@ -1952,19 +1948,19 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode } -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') + enable_code_gen (ModuleNode deps (ModuleNodeCompile 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 (ModuleNode deps ms') + enable_code_gen (ModuleNode deps (ModuleNodeCompile 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 (ModuleNode deps ms') + enable_code_gen (ModuleNode deps (ModuleNodeCompile ms')) | otherwise -> return n @@ -2043,7 +2039,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only -- it's dependencies. [ deps - | (ModuleNode deps ms) <- mod_graph + | (ModuleNode deps (ModuleNodeCompile ms)) <- mod_graph , isTemplateHaskellOrQQNonBoot ms , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)) ] @@ -2052,7 +2048,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = need_bc_set = concat [ deps - | (ModuleNode deps ms) <- mod_graph + | (ModuleNode deps (ModuleNodeCompile ms)) <- mod_graph , isTemplateHaskellOrQQNonBoot ms , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms) ] @@ -2514,9 +2510,14 @@ cyclicModuleErr mss 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))) + ppr_ms :: ModuleNodeInfo -> SDoc + ppr_ms ms = quotes (ppr (moduleNodeInfoModule ms)) <+> + (parens (text (node_path ms))) + + node_path :: ModuleNodeInfo -> FilePath + node_path ms = case ml_hs_file (moduleNodeInfoLocation ms) of + Just f -> f + Nothing -> ml_hi_file (moduleNodeInfoLocation ms) cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () @@ -2609,39 +2610,72 @@ executeInstantiationNode k n deps uid iu = do return res +-- | executeCompileNode interprets how --make module should compile a ModuleNode +-- +-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check +-- if the interface file exists and is up to date. If it is, we return those. +-- Otherwise, we compile the module and return the new HomeModInfo. +-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface +-- and artifacts from disk. + executeCompileNode :: Int -> Int -> Maybe HomeModInfo -> HomeUnitGraph -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling - -> ModSummary + -> ModuleNodeInfo -> RunMakeM HomeModInfo -executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do +executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do me@MakeEnv{..} <- ask -- Rehydrate any dependencies if this module had a boot file or is a signature file. lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do - hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mod fixed_mrehydrate_mods + hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods + case mni of + ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me mod + ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc + ) + + where + fixed_mrehydrate_mods = + case moduleNodeInfoHscSource mni of + -- MP: It is probably a bit of a misimplementation in backpack that + -- compiling a signature requires an knot_var for that unit. + -- If you remove this then a lot of backpack tests fail. + Just HsigFile -> Just [] + _ -> mrehydrate_mods + + executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo) + executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod_key loc = + wrapAction diag_wrapper hsc_env $ do + forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod_key loc)) + read_result <- readIface (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod_key) (ml_hi_file loc) + case read_result of + MB.Failed interface_err -> + + let mn = mnkModuleName mod_key + err = Can'tFindInterface (BadIfaceFile interface_err) (LookingForModule (gwib_mod mn) (gwib_isBoot mn)) + in throwErrors $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (GhcDriverMessage (DriverInterfaceError err)) + MB.Succeeded iface -> do + details <- genModDetails hsc_env iface + mb_object <- findObjectLinkableMaybe (mi_module iface) loc + mb_bytecode <- loadIfaceByteCodeLazy hsc_env iface loc (md_types details) + let hm_linkable = HomeModLinkable mb_bytecode mb_object + return (HomeModInfo iface details hm_linkable) + + executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo) + executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas lcl_dynflags = ms_hspp_opts mod let lcl_hsc_env = -- Localise the hsc_env to use the cached flags hscSetFlags lcl_dynflags $ - hsc_env' + hsc_env -- Compile the module, locking with a semaphore to avoid too many modules -- being compiled at the same time leading to high memory usage. wrapAction diag_wrapper 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 - -- MP: It is probably a bit of a misimplementation in backpack that - -- compiling a signature requires an knot_var for that unit. - -- If you remove this then a lot of backpack tests fail. - HsigFile -> Just [] - _ -> mrehydrate_mods + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags + return res {- Rehydration, see Note [Rehydrating Modules] -} @@ -2669,9 +2703,9 @@ rehydrate hsc_env hmis = do -- If needed, then rehydrate the necessary modules with a suitable KnotVars for the -- module currently being compiled. -maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv +maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv maybeRehydrateBefore hsc_env _ Nothing = return hsc_env -maybeRehydrateBefore hsc_env mod (Just mns) = do +maybeRehydrateBefore hsc_env mni (Just mns) = do knot_var <- initialise_knot_var hsc_env let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var } hmis <- mapM (fmap (expectJust "mr") . lookupHpt (hsc_HPT hsc_env')) mns @@ -2681,7 +2715,7 @@ maybeRehydrateBefore hsc_env mod (Just mns) = do where initialise_knot_var hsc_env = liftIO $ - let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod) + let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni) in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv rehydrateAfter :: HscEnv ===================================== compiler/GHC/Driver/MakeFile.hs ===================================== @@ -14,55 +14,57 @@ module GHC.Driver.MakeFile ) where -import GHC.Prelude - +import Control.Monad (when) +import Data.Either (partitionEithers) +import Data.Foldable (traverse_) +import Data.IORef +import Data.List (partition) +import qualified Data.Set as Set import qualified GHC +import GHC.Data.Graph.Directed (SCC (..)) import GHC.Data.Maybe -import GHC.Driver.Make -import GHC.Driver.Monad -import GHC.Driver.DynFlags -import GHC.Driver.Ppr -import GHC.Driver.MakeFile.JSON -import GHC.Utils.Misc -import GHC.Driver.Env -import GHC.Driver.Errors.Types -import GHC.Driver.Pipeline (runPipeline, TPhase (T_Unlit, T_FileArgs), use, mkPipeEnv) -import GHC.Driver.Phases (StopPhase (StopPreprocess), startPhase, Phase (Unlit)) -import GHC.Driver.Pipeline.Monad (PipelineOutput (NoOutputFile)) -import GHC.Driver.Session (pgm_F) -import qualified GHC.SysTools as SysTools -import GHC.Data.Graph.Directed ( SCC(..) ) -import GHC.Data.OsPath (unsafeDecodeUtf, OsPath, OsString) import qualified GHC.Data.OsPath as OS -import GHC.Utils.Outputable -import GHC.Utils.Panic +import GHC.Data.OsPath (OsPath, OsString, unsafeDecodeUtf) +import GHC.Iface.Errors.Types +import GHC.Iface.Load (cannotFindModule) +import GHC.Prelude +import qualified GHC.SysTools as SysTools +import GHC.Types.PkgQual import GHC.Types.SourceError import GHC.Types.SrcLoc -import GHC.Types.PkgQual -import Data.List (partition) -import GHC.Utils.TmpFs - -import GHC.Iface.Load (cannotFindModule) -import GHC.Iface.Errors.Types - +import GHC.Unit.Finder import GHC.Unit.Module -import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph -import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary import GHC.Unit.State (lookupUnitId) - -import GHC.Utils.Exception import GHC.Utils.Error +import GHC.Utils.Exception import GHC.Utils.Logger - +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.TmpFs import System.Directory import System.FilePath import System.IO -import System.IO.Error ( isEOFError ) -import Control.Monad ( when ) -import Data.Foldable (traverse_) -import Data.IORef -import qualified Data.Set as Set +import System.IO.Error (isEOFError) + +import GHC.Driver.DynFlags +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Make +import GHC.Driver.MakeFile.JSON +import GHC.Driver.Monad +import GHC.Driver.Phases (Phase (Unlit), StopPhase (StopPreprocess), startPhase) +import GHC.Driver.Pipeline ( + TPhase (T_FileArgs, T_Unlit), + mkPipeEnv, + runPipeline, + use, + ) +import GHC.Driver.Pipeline.Monad (PipelineOutput (NoOutputFile)) +import GHC.Driver.Ppr +import GHC.Driver.Session (pgm_F) ----------------------------------------------------------------- -- @@ -234,8 +236,10 @@ processDeps dflags _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:" , nest 2 $ ppr node ] processDeps _dflags_ _ _ _ _ _ (AcyclicSCC (LinkNode {})) = return () - -processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode _ node)) = do +processDeps _ _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) + -- No dependencies needed for fixed modules (already compiled) + = return () +processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do pp <- preprocessor deps <- fmap concat $ sequence $ [cpp_deps | depIncludeCppDeps dflags] ++ [ @@ -472,43 +476,62 @@ pprCycle :: [ModuleGraphNode] -> SDoc -- Print a cycle, but show only the imports within the cycle pprCycle summaries = pp_group (CyclicSCC summaries) where - cycle_mods :: [ModuleName] -- The modules in this cycle - cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries] + cycle_keys :: [NodeKey] -- The modules in this cycle + cycle_keys = map mkNodeKey summaries pp_group :: SCC ModuleGraphNode -> SDoc - pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms + pp_group (AcyclicSCC (ModuleNode deps m)) = pp_mod deps m pp_group (AcyclicSCC _) = empty pp_group (CyclicSCC mss) = assert (not (null boot_only)) $ -- The boot-only list must be non-empty, else there would -- be an infinite chain of non-boot imports, and we've -- already checked for that in processModDeps - pp_ms loop_breaker $$ vcat (map pp_group groups) + pp_mod loop_deps loop_breaker $$ vcat (map pp_group groups) where - (boot_only, others) = partition is_boot_only mss - is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms))) - is_boot_only _ = False - in_group (L _ m) = m `elem` group_mods - group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss] - - loop_breaker = head ([ms | ModuleNode _ ms <- boot_only]) - all_others = tail boot_only ++ others + (boot_only, others) = partitionEithers (map is_boot_only mss) + is_boot_key (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True + is_boot_key _ = False + is_boot_only n@(ModuleNode deps ms) = + let non_boot_deps = filter (not . is_boot_key) deps + in if not (any in_group non_boot_deps) + then Left (deps, ms) + else Right n + is_boot_only n = Right n + in_group m = m `elem` group_mods + group_mods = map mkNodeKey mss + + (loop_deps, loop_breaker) = head boot_only + all_others = tail (map (uncurry ModuleNode) boot_only) ++ others groups = GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing - pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) - <+> (pp_imps empty (map snd (ms_imps summary)) $$ - pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) - where - mod_str = moduleNameString (moduleName (ms_mod summary)) - - pp_imps :: SDoc -> [Located ModuleName] -> SDoc - pp_imps _ [] = empty - pp_imps what lms - = case [m | L _ m <- lms, m `elem` cycle_mods] of - [] -> empty - ms -> what <+> text "imports" <+> - pprWithCommas ppr ms + pp_mod :: [NodeKey] -> ModuleNodeInfo -> SDoc + pp_mod deps mn = + text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <> ppr_deps deps + where + mod_str = moduleNameString (moduleNodeInfoModuleName mn) + + ppr_deps :: [NodeKey] -> SDoc + ppr_deps [] = empty + ppr_deps deps = + let is_mod_dep (NodeKey_Module {}) = True + is_mod_dep _ = False + + is_boot_dep (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True + is_boot_dep _ = False + + cycle_deps = filter (`elem` cycle_keys) deps + (mod_deps, other_deps) = partition is_mod_dep cycle_deps + (boot_deps, normal_deps) = partition is_boot_dep mod_deps + in vcat [ + if null normal_deps then empty + else text "imports" <+> pprWithCommas ppr normal_deps, + if null boot_deps then empty + else text "{-# SOURCE #-} imports" <+> pprWithCommas ppr boot_deps, + if null other_deps then empty + else text "depends on" <+> pprWithCommas ppr other_deps + ] ----------------------------------------------------------------- -- ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -1262,19 +1262,20 @@ dynCompileExpr expr = do ----------------------------------------------------------------------------- -- show a module and it's source/object filenames -showModule :: GhcMonad m => ModSummary -> m String -showModule mod_summary = +showModule :: GhcMonad m => ModuleNodeInfo -> m String +showModule mni = do + let mod = moduleNodeInfoModule mni withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env interpreted <- liftIO $ - HUG.lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) >>= pure . \case + HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case Nothing -> panic "missing linkable" Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info) - return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary)) + return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mni)) -moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool -moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> liftIO $ - HUG.lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) >>= pure . \case +moduleIsBootOrNotObjectLinkable :: GhcMonad m => Module -> m Bool +moduleIsBootOrNotObjectLinkable mod = withSession $ \hsc_env -> liftIO $ + HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case Nothing -> panic "missing linkable" Just mod_info -> isNothing $ homeModInfoByteCode mod_info ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -8,6 +8,12 @@ module GHC.Unit.Module.Graph , nodeDependencies , emptyMG , mkModuleGraph + , mkModuleGraphChecked + + -- * Invariant checking + , checkModuleGraph + , ModuleGraphInvariantError(..) + , extendMG , extendMGInst , extendMG' @@ -22,6 +28,7 @@ module GHC.Unit.Module.Graph , mgHomeModuleMap , showModMsg , moduleGraphNodeModule + , mgNodeIsModule , moduleGraphNodeModSum , moduleGraphModulesBelow , mgReachable @@ -38,46 +45,51 @@ module GHC.Unit.Module.Graph , ModNodeKey , mkNodeKey , msKey - + , mnKey , moduleGraphNodeUnitId , ModNodeKeyWithUid(..) + , mnkToModule + , mnkIsBoot + + , ModuleNodeInfo(..) + , moduleNodeInfoModule + , moduleNodeInfoModuleName + , moduleNodeInfoModNodeKeyWithUid + , moduleNodeInfoHscSource + , moduleNodeInfoLocation + , isBootModuleNodeInfo ) where -import GHC.Prelude -import GHC.Platform - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Data.Maybe +import Data.Bifunctor +import Data.Either +import Data.Function +import Data.List (sort) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) import GHC.Data.Graph.Directed import GHC.Data.Graph.Directed.Reachability - +import GHC.Data.List.SetOps +import GHC.Data.Maybe import GHC.Driver.Backend import GHC.Driver.DynFlags - -import GHC.Types.SourceFile ( hscSourceString, isHsigFile ) - -import GHC.Unit.Module.ModSummary -import GHC.Unit.Types +import qualified GHC.LanguageExtensions as LangExt +import GHC.Linker.Static.Utils +import GHC.Platform +import GHC.Prelude +import GHC.Stack +import GHC.Types.SourceFile (HscSource (..), hscSourceString, isHsigFile) +import GHC.Types.Unique.DSet +import GHC.Utils.Misc (partitionWith) import GHC.Utils.Outputable -import GHC.Utils.Misc ( partitionWith ) - import System.FilePath -import qualified Data.Map as Map -import GHC.Types.Unique.DSet -import qualified Data.Set as Set -import Data.Set (Set) -import GHC.Unit.Module -import GHC.Linker.Static.Utils -import Data.Bifunctor -import Data.Function -import Data.List (sort) -import GHC.Data.List.SetOps -import GHC.Stack +import GHC.Unit.Module +import GHC.Unit.Module.ModSummary +import GHC.Unit.Types -- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'. -- Edges between nodes mark dependencies arising from module imports @@ -86,30 +98,166 @@ data ModuleGraphNode -- | Instantiation nodes track the instantiation of other units -- (backpack dependencies) with the holes (signatures) of the current package. = InstantiationNode UnitId InstantiatedUnit - -- | There is a module summary node for each module, signature, and boot module being built. - | ModuleNode [NodeKey] ModSummary + -- | There is a module node for each module being built. + -- A node is either fixed or can be compiled. + -- - Fixed modules are not compiled, the artifacts are just loaded from disk. + -- It is up to you to make sure the artifacts are up to date and available. + -- - Compile modules are compiled from source if needed. + | ModuleNode [NodeKey] ModuleNodeInfo -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit. | LinkNode [NodeKey] UnitId + +data ModuleGraphInvariantError = + FixedNodeDependsOnCompileNode ModNodeKeyWithUid [NodeKey] + | DuplicateModuleNodeKey NodeKey + | DependencyNotInGraph NodeKey [NodeKey] + deriving (Eq, Ord) + +instance Outputable ModuleGraphInvariantError where + ppr = \case + FixedNodeDependsOnCompileNode key bad_deps -> + text "Fixed node" <+> ppr key <+> text "depends on compile nodes" <+> ppr bad_deps + DuplicateModuleNodeKey k -> + text "Duplicate module node key" <+> ppr k + DependencyNotInGraph from to -> + text "Dependency not in graph" <+> ppr from <+> text "->" <+> ppr to + +-- Used for invariant checking. Is a NodeKey fixed or compilable? +data ModuleNodeType = MN_Fixed | MN_Compile + +instance Outputable ModuleNodeType where + ppr = \case + MN_Fixed -> text "Fixed" + MN_Compile -> text "Compile" + +moduleNodeType :: ModuleGraphNode -> ModuleNodeType +moduleNodeType (ModuleNode _ (ModuleNodeCompile _)) = MN_Compile +moduleNodeType (ModuleNode _ (ModuleNodeFixed _ _)) = MN_Fixed +moduleNodeType _ = MN_Compile + +checkModuleGraph :: ModuleGraph -> [ModuleGraphInvariantError] +checkModuleGraph ModuleGraph{..} = + mapMaybe (checkFixedModuleInvariant node_types) mg_mss + ++ mapMaybe (checkAllDependenciesInGraph node_types) mg_mss + ++ duplicate_errs + where + duplicate_errs = rights (Map.elems node_types) + + node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ] + where + go :: NodeKey -> Either ModuleNodeType ModuleGraphInvariantError + -> Either ModuleNodeType ModuleGraphInvariantError + -> Either ModuleNodeType ModuleGraphInvariantError + go k _ _ = Right (DuplicateModuleNodeKey k) + +checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + -> ModuleGraphNode + -> Maybe ModuleGraphInvariantError +checkAllDependenciesInGraph node_types node = + let nodeKey = mkNodeKey node + deps = nodeDependencies False node + missingDeps = filter (\dep -> not (Map.member dep node_types)) deps + in if null missingDeps + then Nothing + else Just (DependencyNotInGraph nodeKey missingDeps) + +checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + -> ModuleGraphNode + -> Maybe ModuleGraphInvariantError +checkFixedModuleInvariant node_types node = case node of + ModuleNode deps (ModuleNodeFixed key _) -> + let check_node dep = case Map.lookup dep node_types of + Just (Left MN_Compile) -> Just dep + _ -> Nothing + bad_deps = mapMaybe check_node deps + in if null bad_deps + then Nothing + else Just (FixedNodeDependsOnCompileNode key bad_deps) + _ -> Nothing + + +{- Note [Module Types in the ModuleGraph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Modules can be one of two different types in the module graph. + +1. ModuleNodeCompile, modules with source files we can compile. +2. ModuleNodeFixed, modules which we presume are already compiled and available. + +The ModuleGraph can contain a combination of these two types of nodes but must +obey the invariant that Fixed nodes only depend on other Fixed nodes. This invariant +can be checked by the `checkModuleGraph` function, but it's +the responsibility of the code constructing the ModuleGraph to ensure it is upheld. + +At the moment, when using --make mode, GHC itself will only use `ModuleNodeCompile` nodes. + +In oneshot mode, we don't have access to the source files of dependencies but sometimes need to know +information about the module graph still (for example, getLinkDeps). + +In theory, the whole compiler will work if an API program uses ModuleNodeFixed nodes, and +there is a simple test in FixedNodes, which can be extended in future to cover +any missing cases. + +-} +data ModuleNodeInfo = ModuleNodeFixed ModNodeKeyWithUid ModLocation + | ModuleNodeCompile ModSummary + +-- | Extract the Module from a ModuleNodeInfo +moduleNodeInfoModule :: ModuleNodeInfo -> Module +moduleNodeInfoModule (ModuleNodeFixed key _) = mnkToModule key +moduleNodeInfoModule (ModuleNodeCompile ms) = ms_mod ms + +-- | Extract the ModNodeKeyWithUid from a ModuleNodeInfo +moduleNodeInfoModNodeKeyWithUid :: ModuleNodeInfo -> ModNodeKeyWithUid +moduleNodeInfoModNodeKeyWithUid (ModuleNodeFixed key _) = key +moduleNodeInfoModNodeKeyWithUid (ModuleNodeCompile ms) = msKey ms + +-- | Extract the HscSource from a ModuleNodeInfo, if we can determine it. +moduleNodeInfoHscSource :: ModuleNodeInfo -> Maybe HscSource +moduleNodeInfoHscSource (ModuleNodeFixed _ _) = Nothing +moduleNodeInfoHscSource (ModuleNodeCompile ms) = Just (ms_hsc_src ms) + +-- | Extract the ModLocation from a ModuleNodeInfo +moduleNodeInfoLocation :: ModuleNodeInfo -> ModLocation +moduleNodeInfoLocation (ModuleNodeFixed _ loc) = loc +moduleNodeInfoLocation (ModuleNodeCompile ms) = ms_location ms + +-- | Extract the IsBootInterface from a ModuleNodeInfo +isBootModuleNodeInfo :: ModuleNodeInfo -> IsBootInterface +isBootModuleNodeInfo (ModuleNodeFixed mnwib _) = mnkIsBoot mnwib +isBootModuleNodeInfo (ModuleNodeCompile ms) = isBootSummary ms + +-- | Extract the ModuleName from a ModuleNodeInfo +moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName +moduleNodeInfoModuleName m = moduleName (moduleNodeInfoModule m) + moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName -moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn) +moduleGraphNodeModule mgn = moduleNodeInfoModuleName <$> (mgNodeIsModule mgn) moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary moduleGraphNodeModSum (InstantiationNode {}) = Nothing moduleGraphNodeModSum (LinkNode {}) = Nothing -moduleGraphNodeModSum (ModuleNode _ ms) = Just ms +moduleGraphNodeModSum (ModuleNode _ (ModuleNodeCompile ms)) = Just ms +moduleGraphNodeModSum (ModuleNode _ (ModuleNodeFixed {})) = Nothing + +mgNodeIsModule :: ModuleGraphNode -> Maybe ModuleNodeInfo +mgNodeIsModule (InstantiationNode {}) = Nothing +mgNodeIsModule (LinkNode {}) = Nothing +mgNodeIsModule (ModuleNode _ ms) = Just ms moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId moduleGraphNodeUnitId mgn = case mgn of InstantiationNode uid _iud -> uid - ModuleNode _ ms -> toUnitId (moduleUnit (ms_mod ms)) + ModuleNode _ ms -> toUnitId (moduleUnit (moduleNodeInfoModule ms)) LinkNode _ uid -> uid instance Outputable ModuleGraphNode where ppr = \case InstantiationNode _ iuid -> ppr iuid - ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks + ModuleNode nks ms -> ppr (mnKey ms) <+> ppr nks LinkNode uid _ -> text "LN:" <+> ppr uid instance Eq ModuleGraphNode where @@ -146,6 +294,12 @@ data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsB instance Outputable ModNodeKeyWithUid where ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib +mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface +mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib + +mnkToModule :: ModNodeKeyWithUid -> Module +mnkToModule (ModNodeKeyWithUid mnwib uid) = Module (RealUnit (Definite uid)) (gwib_mod mnwib) + -- | A '@ModuleGraph@' contains all the nodes from the home package (only). See -- '@ModuleGraphNode@' for information about the nodes. -- @@ -181,7 +335,8 @@ mapMG f mg@ModuleGraph{..} = mg flip fmap mg_mss $ \case InstantiationNode uid iuid -> InstantiationNode uid iuid LinkNode uid nks -> LinkNode uid nks - ModuleNode deps ms -> ModuleNode deps (f ms) + ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc) + ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms)) unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph unionMG a b = @@ -201,30 +356,30 @@ mkHomeModuleMap nodes = where provider_map = Map.fromListWith Set.union - [ (ms_mod_name ms, Set.singleton (ms_unitid ms)) + [ (moduleNodeInfoModuleName ms, Set.singleton (toUnitId (moduleUnit (moduleNodeInfoModule ms)))) | ModuleNode _ ms <- nodes ] complete_units = Set.fromList - [ ms_unitid ms + [ toUnitId (moduleUnit (moduleNodeInfoModule ms)) | ModuleNode _ ms <- nodes ] mgModSummaries :: ModuleGraph -> [ModSummary] -mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ] +mgModSummaries mg = [ m | ModuleNode _ (ModuleNodeCompile m) <- mgModSummaries' mg ] mgModSummaries' :: ModuleGraph -> [ModuleGraphNode] mgModSummaries' = mg_mss --- | Look up a ModSummary in the ModuleGraph --- Looks up the non-boot ModSummary +-- | Look up a ModuleNodeInfo in the ModuleGraph +-- Looks up the non-boot module -- Linear in the size of the module graph -mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary +mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss where go (ModuleNode _ ms) - | NotBoot <- isBootSummary ms - , ms_mod ms == m + | NotBoot <- isBootModuleNodeInfo ms + , moduleNodeInfoModule ms == m = Just ms go _ = Nothing @@ -261,7 +416,7 @@ extendMG ModuleGraph{..} deps ms = ModuleGraph , mg_has_holes = False } where - new_mss = ModuleNode deps ms : mg_mss + new_mss = ModuleNode deps (ModuleNodeCompile ms) : mg_mss extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph extendMGInst mg uid depUnitId = mg @@ -274,18 +429,32 @@ extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg } extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph extendMG' mg = \case InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId - ModuleNode deps ms -> extendMG mg deps ms + ModuleNode deps (ModuleNodeCompile ms) -> extendMG mg deps ms + ModuleNode deps mni -> mg + { mg_mss = ModuleNode deps mni : mg_mss mg + , mg_graph = mkTransDeps (ModuleNode deps mni : mg_mss mg) + , mg_home_map = mkHomeModuleMap (ModuleNode deps mni : mg_mss mg) + , mg_has_holes = mg_has_holes mg || maybe False isHsigFile (moduleNodeInfoHscSource mni) + } LinkNode deps uid -> extendMGLink mg uid deps mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph mkModuleGraph = foldr (flip extendMG') emptyMG +-- | A version of mkModuleGraph that checks the module graph for invariants. +mkModuleGraphChecked :: [ModuleGraphNode] -> Either [ModuleGraphInvariantError] ModuleGraph +mkModuleGraphChecked nodes = + let mg = mkModuleGraph nodes + in case checkModuleGraph mg of + [] -> Right mg + errors -> Left errors + -- | This function filters out all the instantiation nodes from each SCC of a -- topological sort. Use this with care, as the resulting "strongly connected components" -- may not really be strongly connected in a direct way, as instantiations have been -- removed. It would probably be best to eliminate uses of this function where possible. filterToposortToModules - :: [SCC ModuleGraphNode] -> [SCC ModSummary] + :: [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo] filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case InstantiationNode _ _ -> Nothing LinkNode{} -> Nothing @@ -314,28 +483,43 @@ showModMsg dflags _ (LinkNode {}) = in text exe_file showModMsg _ _ (InstantiationNode _uid indef_unit) = ppr $ instUnitInstanceOf indef_unit -showModMsg dflags recomp (ModuleNode _ mod_summary) = +showModMsg dflags recomp (ModuleNode _ mni) = if gopt Opt_HideSourcePaths dflags then text mod_str else hsep $ [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') , char '(' - , text (op $ msHsFilePath mod_summary) <> char ',' - , message, char ')' ] - + , text (moduleNodeInfoSource mni) <> char ',' + , moduleNodeInfoExtraMessage dflags recomp mni, char ')' ] where - op = normalise - mod_str = moduleNameString (moduleName (ms_mod mod_summary)) ++ - hscSourceString (ms_hsc_src mod_summary) - dyn_file = op $ msDynObjFilePath mod_summary - obj_file = op $ msObjFilePath mod_summary - files = [ obj_file ] - ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ] - ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] - message = case backendSpecialModuleSource (backend dflags) recomp of - Just special -> text special - Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files) - + mod_str = moduleNameString (moduleName (moduleNodeInfoModule mni)) ++ + moduleNodeInfoBootString mni + +-- | Extra information about a 'ModuleNodeInfo' to display in the progress message. +moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc +moduleNodeInfoExtraMessage dflags recomp (ModuleNodeCompile mod_summary) = + let dyn_file = normalise $ msDynObjFilePath mod_summary + obj_file = normalise $ msObjFilePath mod_summary + files = [ obj_file ] + ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ] + ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] + in case backendSpecialModuleSource (backend dflags) recomp of + Just special -> text special + Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files) +moduleNodeInfoExtraMessage _ _ (ModuleNodeFixed {}) = text "fixed" + +-- | The source location of the module node to show to the user. +moduleNodeInfoSource :: ModuleNodeInfo -> FilePath +moduleNodeInfoSource (ModuleNodeCompile ms) = normalise $ msHsFilePath ms +moduleNodeInfoSource (ModuleNodeFixed _ loc) = normalise $ ml_hi_file loc + +-- | The extra info about a module [boot] or [sig] to display. +moduleNodeInfoBootString :: ModuleNodeInfo -> String +moduleNodeInfoBootString (ModuleNodeCompile ms) = hscSourceString (ms_hsc_src ms) +moduleNodeInfoBootString mn@(ModuleNodeFixed {}) = + hscSourceString (case isBootModuleNodeInfo mn of + IsBoot -> HsBootFile + NotBoot -> HsSrcFile) type SummaryNode = Node Int ModuleGraphNode @@ -384,14 +568,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = where go (s, key) = case s of - ModuleNode __deps ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes + ModuleNode __deps ms | isBootModuleNodeInfo ms == IsBoot, drop_hs_boot_nodes -- Using nodeDependencies here converts dependencies on other -- boot files to dependencies on dependencies on non-boot files. - -> Left (ms_mod ms, nodeDependencies drop_hs_boot_nodes s) + -> Left (moduleNodeInfoModule ms, nodeDependencies drop_hs_boot_nodes s) _ -> normal_case where normal_case = - let lkup_key = ms_mod <$> moduleGraphNodeModSum s + let lkup_key = moduleNodeInfoModule <$> mgNodeIsModule s extra = (lkup_key >>= \key -> Map.lookup key boot_summaries) in Right $ DigraphNode s key $ out_edge_keys $ @@ -423,12 +607,16 @@ newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a } mkNodeKey :: ModuleGraphNode -> NodeKey mkNodeKey = \case InstantiationNode _ iu -> NodeKey_Unit iu - ModuleNode _ x -> NodeKey_Module $ msKey x + ModuleNode _ x -> NodeKey_Module $ mnKey x LinkNode _ uid -> NodeKey_Link uid msKey :: ModSummary -> ModNodeKeyWithUid msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms) +mnKey :: ModuleNodeInfo -> ModNodeKeyWithUid +mnKey (ModuleNodeFixed key _) = key +mnKey (ModuleNodeCompile ms) = msKey ms + type ModNodeKey = ModuleNameWithIsBoot ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -1401,10 +1401,11 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> OsPath.pprOsPath db_path - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg logger 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" + when (log_verbosity (logFlags logger) >= 2) $ + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" return (pkg_map', prec_map') where db_map = mk_pkg_map db @@ -2382,4 +2383,3 @@ implicitPackageDeps dflags = [thUnitId | xopt TemplateHaskellQuotes dflags] -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but -- it is possible to not depend on base (for example, see `ghc-prim`) - ===================================== ghc/GHCi/UI.hs ===================================== @@ -61,7 +61,7 @@ import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Resume, SingleStep, Ghc, GetDocsFailure(..), pushLogHookM, - getModuleGraph, handleSourceError, ms_mod ) + getModuleGraph, handleSourceError ) import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation) import GHC.Hs.ImpExp import GHC.Hs @@ -1753,7 +1753,7 @@ editFile str = -- of those. chooseEditFile :: GHC.GhcMonad m => m String chooseEditFile = - do let hasFailed (GHC.ModuleNode _deps x) = fmap not $ isLoadedModSummary x + do let hasFailed (GHC.ModuleNode _deps x) = fmap not $ isLoadedModuleNode x hasFailed _ = return False graph <- GHC.getModuleGraph @@ -1762,7 +1762,7 @@ chooseEditFile = let order g = flattenSCCs $ filterToposortToModules $ GHC.topSortModuleGraph True g Nothing pick xs = case xs of - x : _ -> GHC.ml_hs_file (GHC.ms_location x) + x : _ -> GHC.ml_hs_file (GHC.moduleNodeInfoLocation x) _ -> Nothing case pick (order failed_graph) of @@ -2205,7 +2205,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do (m:_) -> load_this m where - is_loaded (GHC.ModuleNode _ ms) = isLoadedModSummary ms + is_loaded (GHC.ModuleNode _ ms) = isLoadedModuleNode ms is_loaded _ = return False findTarget mds t @@ -2214,13 +2214,13 @@ setContextAfterLoad keep_ctxt (Just graph) = do (m:_) -> Just m (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetModule m } - = if GHC.ms_mod_name summary == m then Just summary else Nothing + = if GHC.moduleNodeInfoModuleName summary == m then Just summary else Nothing (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetFile f _ } - | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = + | Just f' <- GHC.ml_hs_file (GHC.moduleNodeInfoLocation summary) = if f == f' then Just summary else Nothing _ `matches` _ = Nothing - load_this summary | m <- GHC.ms_mod summary = do + load_this summary | m <- GHC.moduleNodeInfoModule summary = do is_interp <- GHC.moduleIsInterpreted m dflags <- getDynFlags let star_ok = is_interp && not (safeLanguageOn dflags) @@ -2270,7 +2270,7 @@ keepPackageImports = filterM is_pkg_import -modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> LoadType -> m () +modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModuleNodeInfo] -> LoadType -> m () modulesLoadedMsg ok mods load_type = do dflags <- getDynFlags when (verbosity dflags > 0) $ do @@ -2307,11 +2307,11 @@ modulesLoadedMsg ok mods load_type = do | otherwise = "Failed" mod_name mod = do - is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod + is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable (GHC.moduleNodeInfoModule mod) pure $ if is_interpreted - then ppr (GHC.ms_mod mod) - else ppr (GHC.ms_mod mod) - <+> parens (text $ normalise $ msObjFilePath mod) + then ppr (GHC.moduleNodeInfoModule mod) + else ppr (GHC.moduleNodeInfoModule mod) + <+> parens (text $ normalise $ (ml_obj_file (GHC.moduleNodeInfoLocation mod))) -- Fix #9887 -- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors @@ -3376,10 +3376,10 @@ showModules = do let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m) mapM_ show_one loaded_mods -getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary] +getLoadedModules :: GHC.GhcMonad m => m [GHC.ModuleNodeInfo] getLoadedModules = do graph <- GHC.getModuleGraph - filterM isLoadedModSummary (GHC.mgModSummaries graph) + filterM isLoadedModuleNode (mapMaybe GHC.mgNodeIsModule (GHC.mgModSummaries' graph)) showBindings :: GHC.GhcMonad m => m () showBindings = do @@ -3407,8 +3407,10 @@ showBindings = do printTyThing :: GHC.GhcMonad m => TyThing -> m () printTyThing tyth = printForUser (pprTyThing showToHeader tyth) -isLoadedModSummary :: GHC.GhcMonad m => ModSummary -> m Bool -isLoadedModSummary ms = GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms) +isLoadedModuleNode :: GHC.GhcMonad m => GHC.ModuleNodeInfo -> m Bool +isLoadedModuleNode ms = + let m = GHC.moduleNodeInfoModule ms + in GHC.isLoadedModule (moduleUnitId m) (moduleName m) {- Note [Filter bindings] @@ -3697,7 +3699,7 @@ completeModule = wrapIdentCompleterMod $ \w -> do hsc_env <- GHC.getSession query <- liftIO $ hscUnitIndexQuery hsc_env let pkg_mods = allVisibleModules (hsc_units hsc_env) query - loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules + loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods @@ -3710,7 +3712,7 @@ completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do return $ map iiModuleName imports _ -> do let pkg_mods = allVisibleModules (hsc_units hsc_env) query - loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules + loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules @@ -4360,11 +4362,11 @@ listModuleLine modl line = do graph <- GHC.getModuleGraph let this = GHC.mgLookupModule graph modl case this of - Nothing -> panic "listModuleLine" - Just summ -> do + Just (GHC.ModuleNodeCompile summ) -> do let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ)) loc = mkRealSrcLoc (mkFastString (filename)) line 0 listAround (realSrcLocSpan loc) False + _ -> panic "listModuleLine" -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit bca637b3738490fed62f228ae4c90834a72de552 +Subproject commit 2bf01c6a9dcf6ec54f5ce99b16a411d4b13f5be9 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a1c0d246ec2ac4a21571e4a1b6ded4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a1c0d246ec2ac4a21571e4a1b6ded4... You're receiving this email because of your account on gitlab.haskell.org.