[Git][ghc/ghc][wip/mpickering/get-link-deps] Cleanup
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Mon Jan 6 14:51:25 UTC 2025
Matthew Pickering pushed to branch wip/mpickering/get-link-deps at Glasgow Haskell Compiler / GHC
Commits:
d2cc0047 by Matthew Pickering at 2025-01-06T14:51:11+00:00
Cleanup
- - - - -
11 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Unit/Module/External/Graph.hs
- compiler/GHC/Unit/Module/ModIface.hs
- testsuite/tests/backpack/should_compile/bkp09.stderr
- testsuite/tests/backpack/should_compile/bkp15.stderr
- testsuite/tests/backpack/should_compile/bkp47.stderr
- testsuite/tests/backpack/should_compile/bkp61.stderr
- testsuite/tests/backpack/should_fail/bkpfail09.stderr
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -260,10 +260,6 @@ depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do
-- 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.
---
--- In the future, perhaps more of the work of instantiation could be moved here,
--- instead of shoved in with the module compilation nodes. That could simplify
--- backpack, and maybe hs-boot too.
instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)]
instantiationNodes uid unit_state = map (uid,) iuids_to_check
where
@@ -1490,15 +1486,15 @@ topSortModuleGraph
-- the a source-import of Foo is an import of Foo
-- The resulting graph has no hi-boot nodes, but can be cyclic
topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =
- -- stronglyConnCompG flips the original order, so if we reverse
- -- the summaries we get a stable topological sort.
- topSortModules drop_hs_boot_nodes (sortBy (cmpModuleGraphNodes `on` mkNodeKey) $ mgModSummaries' module_graph) mb_root_mod
+ topSortModules drop_hs_boot_nodes
+ (sortBy (cmpModuleGraphNodes `on` mkNodeKey) $ mgModSummaries' module_graph)
+ mb_root_mod
where
-- In order to get the "right" ordering
-- Module nodes must be in reverse lexigraphic order.
- -- All modules nodes must appear before package nodes or link nodes.
+ -- All modules nodes must appear before package nodes.
--
-- MP: This is just the ordering which the tests needed in Jan 2025, it does
-- not arise from nature.
@@ -1506,6 +1502,12 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =
-- Given the current implementation of scc, the result is in
-- The order is sensitive to the internal implementation in Data.Graph,
-- if it changes in future then this ordering will need to be modified.
+ --
+ -- The SCC algorithm firstly transposes the input graph and then
+ -- performs dfs on the vertices in the order which they are originally given.
+ -- Therefore, if `ExternalUnit` nodes are first, the order returned will
+ -- be determined by the order the dependencies are stored in the transposed graph.
+ moduleGraphNodeRank :: NodeKey -> Int
moduleGraphNodeRank k =
case k of
NodeKey_Unit {} -> 0
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -411,18 +411,13 @@ loadInterfaceWithException doc mod_name where_from
let ctx = initSDocContext dflags defaultUserStyle
withIfaceErr ctx (loadInterface doc mod_name where_from)
--- | Load all interfaces from the home package that are transitively reachable
--- from the given modules -- presumes that this operation can be completed by
--- traversing from the already loaded home packages.
+-- | Load the part of the external module graph which is transitively reachable
+-- from the given modules.
--
-- This operation is used just before TH splices are run (in 'getLinkDeps').
--
-- A field in the EPS tracks which home modules are already fully loaded, which we use
-- here to avoid trying to load them a second time.
---
--- For convenience, reads the module graph out of the EPS after having loaded
--- all the modules and returns it. It would be harder to get the updated module
--- graph in 'getLinkDeps' another way.
loadExternalGraphBelow :: (Module -> SDoc) -> Maybe HomeUnit {-^ The current home unit -}
-> Set.Set ExternalKey -> [Module] -> IfM lcl (Set.Set ExternalKey)
loadExternalGraphBelow _ Nothing _ _ = panic "loadHomePackageInterfacesBelow: No home unit"
@@ -430,7 +425,9 @@ loadExternalGraphBelow msg (Just home_unit) init_loaded mods =
foldM (loadExternalGraphModule msg home_unit) init_loaded mods
loadExternalGraphModule :: (Module -> SDoc) -> HomeUnit
- -> Set.Set ExternalKey -> Module -> IfM lcl (Set.Set ExternalKey)
+ -> Set.Set ExternalKey
+ -> Module
+ -> IfM lcl (Set.Set ExternalKey)
loadExternalGraphModule msg home_unit init_loaded mod
| homeUnitId home_unit /= moduleUnitId mod = do
loadExternalPackageBelow init_loaded (moduleUnitId mod)
@@ -458,14 +455,6 @@ actuallyLoadExternalGraphModule msg home_unit new_cache key mod = do
iface <- withIfaceErr ctx $
loadInterface (msg mod) mod (ImportByUser NotBoot)
- -- RM:TODO: THINGS WE ARE NOT DOING
- --
- -- The ModIface contains the transitive closure of the module dependencies
- -- within the current package, *except* for boot modules: if we encounter
- -- a boot module, we have to find its real interface and discover the
- -- dependencies of that. Hence we need to traverse the dependency
- -- tree recursively. See bug #936, testcase ghci/prog007.
-
let deps = mi_deps iface
mod_deps = dep_direct_mods deps
pkg_deps = dep_direct_pkgs deps
@@ -511,7 +500,9 @@ loadExternalPackageBelow cache uid = do
loadPackageIntoEPSGraph :: UnitId -> [UnitId] -> IfM lcl ()
loadPackageIntoEPSGraph uid dep_uids =
updateEps_ $ \eps ->
- eps { eps_module_graph = extendExternalModuleGraph (NodeExternalPackage uid (Set.fromList dep_uids)) (eps_module_graph eps) }
+ eps { eps_module_graph =
+ extendExternalModuleGraph (NodeExternalPackage uid
+ (Set.fromList dep_uids)) (eps_module_graph eps) }
------------------
@@ -624,7 +615,7 @@ loadInterface doc_str mod from
; let direct_deps = map (uncurry (flip ModNodeKeyWithUid)) $ (Set.toList (dep_direct_mods $ mi_deps iface))
; let direct_pkg_deps = Set.toList $ dep_direct_pkgs $ mi_deps iface
- ; let !module_graph_key = -- pprTrace "module_graph_on_load" (ppr (eps_module_graph eps)) $
+ ; let !module_graph_key =
if moduleUnitId mod `elem` hsc_all_home_unit_ids hsc_env
--- ^ home unit mods in eps can only happen in oneshot mode
then Just $ NodeHomePackage (miKey iface) (map ExternalModuleKey direct_deps
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -60,8 +60,6 @@ import Control.Monad (forM)
data LinkDepsOpts = LinkDepsOpts
{ ldObjSuffix :: !String -- ^ Suffix of .o files
, ldForceDyn :: !Bool -- ^ Always use .dyn_o?
- , ldOneShotMode :: !Bool -- ^ Is the driver in one-shot mode?
- , ldModuleGraph :: !ModuleGraph
, ldUnitEnv :: !UnitEnv
, ldPprOpts :: !SDocContext -- ^ Rendering options for error messages
, ldUseByteCode :: !Bool -- ^ Use bytecode rather than objects
@@ -70,8 +68,7 @@ data LinkDepsOpts = LinkDepsOpts
, ldFinderCache :: !FinderCache
, ldFinderOpts :: !FinderOpts
, ldLoadByteCode :: !(Module -> IO (Maybe Linkable))
- , ldLoadHomeIfacesBelow :: !((Module -> SDoc) -> Maybe HomeUnit {- current home unit -}
- -> [Module] -> IO ExternalPackageState {- EPS after loading -})
+ , ldGetDependencies :: !([Module] -> IO ([Module], UniqDSet UnitId))
}
data LinkDeps = LinkDeps
@@ -117,7 +114,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- 1. Find the dependent home-pkg-modules/packages from each iface
-- (omitting modules from the interactive package, which is already linked)
- (mods_s, pkgs_s) <- get_reachable_nodes opts relevant_mods
+ (mods_s, pkgs_s) <- ldGetDependencies opts relevant_mods
let
-- 2. Exclude ones already linked
@@ -215,88 +212,6 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
CoreBindings WholeCoreBindings {wcb_module} ->
pprPanic "Unhydrated core bindings" (ppr wcb_module)
--- See Note [Reachability in One-shot mode vs Make mode]
-get_reachable_nodes :: LinkDepsOpts -> [Module] -> IO ([Module], UniqDSet UnitId)
-get_reachable_nodes opts mods
-
- -- Reachability on 'ExternalModuleGraph' (for one shot mode)
- | ldOneShotMode opts
- = do
- eps <- ldLoadHomeIfacesBelow opts msg (ue_homeUnit (ldUnitEnv opts)) mods
- let
- emg = eps_module_graph eps
- get_mod_info_eps (ModNodeKeyWithUid gwib uid)
- | uid == homeUnitId (ue_unsafeHomeUnit unit_env)
- = case lookupModuleEnv (eps_PIT eps) (Module (RealUnit $ Definite uid) (gwib_mod gwib)) of
- Just iface -> return $ Just iface
- Nothing -> moduleNotLoaded "(in EPS)" gwib uid
- | otherwise
- = return Nothing
-
- get_mod_key m
- | moduleUnitId m == homeUnitId (ue_unsafeHomeUnit unit_env)
- = ExternalModuleKey (mkModuleNk m)
- | otherwise = ExternalPackageKey (moduleUnitId m)
-
- go get_mod_key emgNodeKey (emgReachableMany emg) (map emgProject) get_mod_info_eps
-
- -- Reachability on 'ModuleGraph' (for --make mode)
- | otherwise
- = go hmgModKey mkNodeKey (mgReachableLoop hmGraph) (catMaybes . map hmgProject) get_mod_info_hug
-
- where
- unit_env = ldUnitEnv opts
- mkModuleNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
- msg mod =
- text "need to link module" <+> ppr mod <+>
- text "and the modules below it, due to use of Template Haskell"
-
- hmGraph = ldModuleGraph opts
-
- hmgModKey m
- | let k = NodeKey_Module (mkModuleNk m)
- , mgMember hmGraph k = k
- | otherwise = NodeKey_ExternalUnit (moduleUnitId m)
-
- hmgProject = \case
- NodeKey_Module with_uid -> Just $ Left with_uid
- NodeKey_ExternalUnit uid -> Just $ Right uid
- _ -> Nothing
-
- emgProject = \case
- ExternalModuleKey with_uid -> Left with_uid
- ExternalPackageKey uid -> Right uid
-
- -- The main driver for getting dependencies, which calls the given
- -- functions to compute the reachable nodes.
- go :: (Module -> key)
- -> (node -> key)
- -> ([key] -> [node])
- -> ([key] -> [Either ModNodeKeyWithUid UnitId])
- -> (ModNodeKeyWithUid -> IO (Maybe ModIface))
- -> IO ([Module], UniqDSet UnitId)
- go modKey nodeKey manyReachable project get_mod_info
- | let mod_keys = map modKey mods
- = do
- let (all_home_mods, pkgs_s) = partitionEithers $ project $ mod_keys ++ map nodeKey (manyReachable mod_keys)
- ifaces <- mapMaybeM get_mod_info all_home_mods
- mods_s <- forM ifaces $ \iface -> case mi_hsc_src iface of
- HsBootFile -> link_boot_mod_error (mi_module iface)
- _ -> return $ mi_module iface
- return (mods_s, mkUniqDSet pkgs_s)
-
- get_mod_info_hug (ModNodeKeyWithUid gwib uid)
- | Just hmi <- lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib)
- = return $ Just (hm_iface hmi)
- | otherwise
- = moduleNotLoaded "(in HUG)" gwib uid
-
- moduleNotLoaded m gwib uid = throwProgramError opts $
- text "getLinkDeps: Home module not loaded" <+> text m <+> ppr (gwib_mod gwib) <+> ppr uid
-
- link_boot_mod_error mod = throwProgramError opts $
- text "module" <+> ppr mod <+>
- text "cannot be linked; it is only available as a boot module"
{-
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -76,8 +76,14 @@ import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Unit.Env
-import GHC.Unit.External (ExternalPackageState (EPS, eps_iface_bytecode))
+import GHC.Unit.Home
+import GHC.Unit.Home.ModInfo
+import GHC.Unit.External (ExternalPackageState (..))
import GHC.Unit.Module
+import GHC.Unit.Module.ModNodeKey
+import GHC.Unit.Module.External.Graph
+import GHC.Unit.Module.Graph
+import GHC.Unit.Module.ModIface
import GHC.Unit.State as Packages
import qualified GHC.Data.ShortText as ST
@@ -97,6 +103,7 @@ import qualified Data.Foldable as Foldable
import Data.IORef
import Data.List (intercalate, isPrefixOf, nub, partition)
import Data.Maybe
+import Data.Either
import Control.Concurrent.MVar
import qualified Control.Monad.Catch as MC
import qualified Data.List.NonEmpty as NE
@@ -594,8 +601,6 @@ initLinkDepsOpts hsc_env = opts
opts = LinkDepsOpts
{ ldObjSuffix = objectSuf dflags
, ldForceDyn = sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags
- , ldOneShotMode = isOneShot (ghcMode dflags)
- , ldModuleGraph = hsc_mod_graph hsc_env
, ldUnitEnv = hsc_unit_env hsc_env
, ldPprOpts = initSDocContext dflags defaultUserStyle
, ldFinderCache = hsc_FC hsc_env
@@ -603,22 +608,96 @@ initLinkDepsOpts hsc_env = opts
, ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags
, ldMsgOpts = initIfaceMessageOpts dflags
, ldWays = ways dflags
- , ldLoadHomeIfacesBelow
+ , ldGetDependencies = get_reachable_nodes hsc_env
, ldLoadByteCode
}
dflags = hsc_dflags hsc_env
- ldLoadHomeIfacesBelow msg hu mods
- = do
- initIfaceCheck (text "loader") hsc_env
- $ void $ loadExternalGraphBelow msg hu Set.empty mods
- -- Read the EPS only after `loadHomePackageInterfacesBelow`
- hscEPS hsc_env
ldLoadByteCode mod = do
EPS {eps_iface_bytecode} <- hscEPS hsc_env
sequence (lookupModuleEnv eps_iface_bytecode mod)
+-- See Note [Reachability in One-shot mode vs Make mode]
+get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId)
+get_reachable_nodes hsc_env mods
+
+ -- Reachability on 'ExternalModuleGraph' (for one shot mode)
+ | isOneShot (ghcMode dflags)
+ = do
+ initIfaceCheck (text "loader") hsc_env
+ $ void $ loadExternalGraphBelow msg (hsc_home_unit_maybe hsc_env) Set.empty mods
+ -- Read the EPS only after `loadHomePackageInterfacesBelow`
+ eps <- hscEPS hsc_env
+ let
+ emg = eps_module_graph eps
+ get_mod_info_eps (ModNodeKeyWithUid gwib uid)
+ | uid == homeUnitId (ue_unsafeHomeUnit unit_env)
+ = case lookupModuleEnv (eps_PIT eps) (Module (RealUnit $ Definite uid) (gwib_mod gwib)) of
+ Just iface -> return $ Just iface
+ Nothing -> moduleNotLoaded "(in EPS)" gwib uid
+ | otherwise
+ = return Nothing
+
+ get_mod_key m
+ | moduleUnitId m == homeUnitId (ue_unsafeHomeUnit unit_env)
+ = ExternalModuleKey (mkModuleNk m)
+ | otherwise = ExternalPackageKey (moduleUnitId m)
+
+ go get_mod_key emgNodeKey (emgReachableLoopMany emg) (map emgProject) get_mod_info_eps
+
+ -- Reachability on 'ModuleGraph' (for --make mode)
+ | otherwise
+ = go hmgModKey mkNodeKey (mgReachableLoop hmGraph) (catMaybes . map hmgProject) get_mod_info_hug
+
+ where
+ dflags = hsc_dflags hsc_env
+ unit_env = hsc_unit_env hsc_env
+ mkModuleNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
+ msg mod =
+ text "need to link module" <+> ppr mod <+>
+ text "and the modules below it, due to use of Template Haskell"
+
+ hmGraph = hsc_mod_graph hsc_env
+
+ hmgModKey m
+ | let k = NodeKey_Module (mkModuleNk m)
+ , mgMember hmGraph k = k
+ | otherwise = NodeKey_ExternalUnit (moduleUnitId m)
+
+ hmgProject = \case
+ NodeKey_Module with_uid -> Just $ Left with_uid
+ NodeKey_ExternalUnit uid -> Just $ Right uid
+ _ -> Nothing
+
+ emgProject = \case
+ ExternalModuleKey with_uid -> Left with_uid
+ ExternalPackageKey uid -> Right uid
+
+ -- The main driver for getting dependencies, which calls the given
+ -- functions to compute the reachable nodes.
+ go :: (Module -> key)
+ -> (node -> key)
+ -> ([key] -> [node])
+ -> ([key] -> [Either ModNodeKeyWithUid UnitId])
+ -> (ModNodeKeyWithUid -> IO (Maybe ModIface))
+ -> IO ([Module], UniqDSet UnitId)
+ go modKey nodeKey manyReachable project get_mod_info
+ | let mod_keys = map modKey mods
+ = do
+ let (all_home_mods, pkgs_s) = partitionEithers $ project $ mod_keys ++ map nodeKey (manyReachable mod_keys)
+ ifaces <- mapMaybeM get_mod_info all_home_mods
+ let mods_s = map mi_module ifaces
+ return (mods_s, mkUniqDSet pkgs_s)
+
+ get_mod_info_hug (ModNodeKeyWithUid gwib uid)
+ | Just hmi <- lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib)
+ = return $ Just (hm_iface hmi)
+ | otherwise
+ = moduleNotLoaded "(in HUG)" gwib uid
+
+ moduleNotLoaded m gwib uid = throwGhcExceptionIO $ ProgramError $ showSDoc dflags $
+ text "getLinkDeps: Home module not loaded" <+> text m <+> ppr (gwib_mod gwib) <+> ppr uid
{- **********************************************************************
=====================================
compiler/GHC/Unit/Module/External/Graph.hs
=====================================
@@ -50,8 +50,8 @@ module GHC.Unit.Module.External.Graph
--
-- | Fast reachability queries on the external module graph. Similar to
-- reachability queries on 'GHC.Unit.Module.Graph'.
- , emgReachable
- , emgReachableMany
+ , emgReachableLoop
+ , emgReachableLoopMany
) where
import GHC.Prelude
@@ -60,10 +60,12 @@ import GHC.Data.Graph.Directed.Reachability
import GHC.Data.Graph.Directed
import qualified Data.Map as M
import qualified Data.Set as S
-import Data.Bifunctor (first)
+import Data.Bifunctor (first, bimap)
import Data.Maybe
import GHC.Utils.Outputable
-import GHC.Unit.Types (UnitId)
+import GHC.Unit.Types (UnitId, GenWithIsBoot(..), IsBootInterface(..), mkModule)
+import GHC.Utils.Misc
+
--------------------------------------------------------------------------------
-- * Main
@@ -71,6 +73,7 @@ import GHC.Unit.Types (UnitId)
data ExternalModuleGraph = ExternalModuleGraph
{ external_nodes :: [ExternalGraphNode]
+ -- This transitive dependency query does not contain hs-boot nodes.
, external_trans :: (ReachabilityIndex ExternalNode, ExternalKey -> Maybe ExternalNode)
, external_fully_loaded :: !(S.Set ExternalKey) }
@@ -103,10 +106,17 @@ emptyExternalModuleGraph :: ExternalModuleGraph
emptyExternalModuleGraph = ExternalModuleGraph [] (graphReachability emptyGraph, const Nothing) S.empty
-- | Get the dependencies of an 'ExternalNode'
-emgNodeDeps :: ExternalGraphNode -> [ExternalKey]
-emgNodeDeps = \case
- NodeHomePackage _ dps -> dps
+emgNodeDeps :: Bool -> ExternalGraphNode -> [ExternalKey]
+emgNodeDeps drop_hs_boot_nodes = \case
+ NodeHomePackage _ dps -> map drop_hs_boot dps
NodeExternalPackage _ dps -> map ExternalPackageKey $ S.toList dps
+ where
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
+ | otherwise = IsBoot
+
+ drop_hs_boot (ExternalModuleKey (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (ExternalModuleKey (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid))
+ drop_hs_boot x = x
-- | The graph key for a given node
emgNodeKey :: ExternalGraphNode -> ExternalKey
@@ -126,11 +136,10 @@ extendExternalModuleGraph node ExternalModuleGraph{..} =
ExternalModuleGraph
{ external_fully_loaded = external_fully_loaded
, external_nodes = node : external_nodes
- , external_trans = first graphReachability $
- externalGraphNodes (node : external_nodes)
+ , external_trans = first cyclicGraphReachability $
+ externalGraphNodes True (node : external_nodes)
}
-
--------------------------------------------------------------------------------
-- * Loading
--------------------------------------------------------------------------------
@@ -149,15 +158,15 @@ setFullyLoadedModule key graph = graph { external_fully_loaded = S.insert key (e
-- transitive closure.
--
-- @Nothing@ if the key couldn't be found in the graph.
-emgReachable :: ExternalModuleGraph -> ExternalKey -> Maybe [ExternalGraphNode]
-emgReachable mg nk = map node_payload <$> modules_below where
+emgReachableLoop :: ExternalModuleGraph -> ExternalKey -> Maybe [ExternalGraphNode]
+emgReachableLoop mg nk = map node_payload <$> modules_below where
(td_map, lookup_node) = external_trans mg
modules_below =
allReachable td_map <$> lookup_node nk
-- | Return all nodes reachable from all of the given keys.
-emgReachableMany :: ExternalModuleGraph -> [ExternalKey] -> [ExternalGraphNode]
-emgReachableMany mg nk = map node_payload modules_below where
+emgReachableLoopMany :: ExternalModuleGraph -> [ExternalKey] -> [ExternalGraphNode]
+emgReachableLoopMany mg nk = map node_payload modules_below where
(td_map, lookup_node) = external_trans mg
modules_below =
allReachableMany td_map (mapMaybe lookup_node nk)
@@ -167,18 +176,38 @@ emgReachableMany mg nk = map node_payload modules_below where
--------------------------------------------------------------------------------
-- | Turn a list of graph nodes into an efficient queriable graph.
-externalGraphNodes ::
- [ExternalGraphNode]
+-- The first boolean parameter indicates whether nodes corresponding to hs-boot files
+-- should be collapsed into their relevant hs nodes.
+externalGraphNodes :: Bool
+ -> [ExternalGraphNode]
-> (Graph ExternalNode, ExternalKey -> Maybe ExternalNode)
-externalGraphNodes summaries =
+externalGraphNodes drop_hs_boot_nodes summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
-- Map from module to extra boot summary dependencies which need to be merged in
- nodes = map go numbered_summaries
+ (boot_summaries, nodes) = bimap M.fromList id $ partitionWith go numbered_summaries
where
- go (s, key) = DigraphNode s key $ out_edge_keys $
- (emgNodeDeps s)
+ go (s, key) =
+ case s of
+ NodeHomePackage (ModNodeKeyWithUid (GWIB mn IsBoot) uid) _deps | drop_hs_boot_nodes
+ -- Using emgNodeDeps here converts dependencies on other
+ -- boot files to dependencies on dependencies on non-boot files.
+ -> Left (mkModule uid mn, emgNodeDeps drop_hs_boot_nodes s)
+ _ -> normal_case
+ where
+ normal_case =
+ let lkup_key =
+ case s of
+ NodeHomePackage (ModNodeKeyWithUid (GWIB mn IsBoot) uid) _deps
+ -> Just $ mkModule uid mn
+ _ -> Nothing
+
+ extra = (lkup_key >>= \key -> M.lookup key boot_summaries)
+
+ in Right $ DigraphNode s key $ out_edge_keys $
+ (fromMaybe [] extra
+ ++ emgNodeDeps drop_hs_boot_nodes s)
numbered_summaries = zip summaries [1..]
@@ -191,12 +220,14 @@ externalGraphNodes summaries =
node_map :: M.Map ExternalKey ExternalNode
node_map =
M.fromList [ (emgNodeKey s, node)
- | node <- nodes
- , let s = node_payload node
- ]
+ | node <- nodes
+ , let s = node_payload node
+ ]
out_edge_keys :: [ExternalKey] -> [Int]
out_edge_keys = mapMaybe lookup_key
+ -- If we want keep_hi_boot_nodes, then we do lookup_key with
+ -- IsBoot; else False
instance Outputable ExternalGraphNode where
ppr = \case
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -362,7 +362,6 @@ data ModIface_ (phase :: ModIfacePhase)
-- See Note [Sharing of ModIface].
}
-
-- Enough information to reconstruct the top level environment for a module
data IfaceTopEnv
= IfaceTopEnv
=====================================
testsuite/tests/backpack/should_compile/bkp09.stderr
=====================================
@@ -1,6 +1,6 @@
-
bkp09.bkp:1:26: warning: [GHC-53692] [-Wdeprecated-flags (in -Wdefault)]
-XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+
[1 of 5] Processing p
[1 of 1] Compiling H[sig] ( p/H.hsig, nothing )
[2 of 5] Processing q
=====================================
testsuite/tests/backpack/should_compile/bkp15.stderr
=====================================
@@ -1,6 +1,6 @@
-
bkp15.bkp:1:26: warning: [GHC-53692] [-Wdeprecated-flags (in -Wdefault)]
-XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+
[1 of 5] Processing p
[1 of 1] Compiling H[sig] ( p/H.hsig, nothing )
[2 of 5] Processing q
=====================================
testsuite/tests/backpack/should_compile/bkp47.stderr
=====================================
@@ -5,10 +5,10 @@
[3 of 3] Processing r
[1 of 4] Compiling A[sig] ( r/A.hsig, nothing )
[2 of 4] Compiling B ( r/B.hs, nothing )
-
bkp47.bkp:19:18: warning: [GHC-06201] [-Wmissing-methods (in -Wdefault)]
• No explicit implementation for
either ‘f’ or ‘g’
• In the instance declaration for ‘C Int’
+
[3 of 4] Instantiating p
[4 of 4] Instantiating q
=====================================
testsuite/tests/backpack/should_compile/bkp61.stderr
=====================================
@@ -1,15 +1,15 @@
[1 of 3] Processing p
- [1 of 2] Compiling H[sig] ( p\H.hsig, nothing )
- [2 of 2] Compiling A ( p\A.hs, nothing )
+ [1 of 2] Compiling H[sig] ( p/H.hsig, nothing )
+ [2 of 2] Compiling A ( p/A.hs, nothing )
[2 of 3] Processing q
Instantiating q
- [1 of 1] Compiling H ( q\H.hs, bkp61.out\q\H.o )
+ [1 of 1] Compiling H ( q/H.hs, bkp61.out/q/H.o )
[3 of 3] Processing r
Instantiating r
[1 of 2] Including q
[2 of 2] Including p[H=q:H]
Instantiating p[H=q:H]
- [1 of 2] Compiling H[sig] ( p\H.hsig, bkp61.out\p\p-D5Mg3foBSCrDbQDKH4WGSG\H.o )
- [2 of 2] Compiling A ( p\A.hs, bkp61.out\p\p-D5Mg3foBSCrDbQDKH4WGSG\A.o )
- [1 of 2] Compiling N ( r\N.hs, bkp61.out\r\N.o )
+ [1 of 2] Compiling H[sig] ( p/H.hsig, bkp61.out/p/p-D5Mg3foBSCrDbQDKH4WGSG/H.o )
+ [2 of 2] Compiling A ( p/A.hs, bkp61.out/p/p-D5Mg3foBSCrDbQDKH4WGSG/A.o )
+ [1 of 2] Compiling N ( r/N.hs, bkp61.out/r/N.o )
[2 of 2] Instantiating p
=====================================
testsuite/tests/backpack/should_fail/bkpfail09.stderr
=====================================
@@ -1,13 +1,12 @@
[1 of 3] Processing p
- [1 of 2] Compiling H[sig] ( p\H.hsig, nothing )
- [2 of 2] Compiling A ( p\A.hs, nothing )
+ [1 of 2] Compiling H[sig] ( p/H.hsig, nothing )
+ [2 of 2] Compiling A ( p/A.hs, nothing )
[2 of 3] Processing q
Instantiating q
- [1 of 1] Compiling H ( q\H.hs, bkpfail09.out\q\H.o )
+ [1 of 1] Compiling H ( q/H.hs, bkpfail09.out/q/H.o )
[3 of 3] Processing r
- [1 of 3] Compiling H2[sig] ( r\H2.hsig, nothing )
+ [1 of 3] Compiling H2[sig] ( r/H2.hsig, nothing )
[2 of 3] Instantiating p
-
Command line argument: -unit-id p[H=H]:0:0: error: [GHC-93011]
• ‘H’ is exported by the hsig file, but not exported by the implementing module ‘q:H’
• While checking that ‘q:H’ implements signature ‘H’ in ‘p[H=q:H]’.
@@ -15,3 +14,4 @@ Command line argument: -unit-id p[H=H]:0:0: error: [GHC-93011]
Command line argument: -unit-id p[H=H]:0:0: error: [GHC-93011]
• ‘H’ is exported by the hsig file, but not exported by the implementing module ‘q:H’
• While checking that ‘q:H’ implements signature ‘H’ in ‘p[H=q:H]’.
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d2cc0047fd79f9833ec42d27b9a27583c7745ed2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d2cc0047fd79f9833ec42d27b9a27583c7745ed2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250106/376ad2a4/attachment-0001.html>
More information about the ghc-commits
mailing list