[Git][ghc/ghc][wip/splice-imports-2024] 3 commits: levelled eps
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu Oct 31 16:33:05 UTC 2024
Matthew Pickering pushed to branch wip/splice-imports-2024 at Glasgow Haskell Compiler / GHC
Commits:
d7e7ca31 by Matthew Pickering at 2024-10-30T15:29:07+00:00
levelled eps
- - - - -
de087b5f by Matthew Pickering at 2024-10-30T15:29:12+00:00
Revert "levelled eps"
This reverts commit d7e7ca319c5ab2070629e50963be8b1c9081258c.
- - - - -
3e18b3d7 by Matthew Pickering at 2024-10-31T16:32:31+00:00
instances
- - - - -
11 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Unit/Module/Graph.hs
- ghc/GHCi/UI.hs
- utils/haddock/haddock-api/src/Haddock/Interface.hs
Changes:
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -580,7 +580,7 @@ mkBackpackMsg = do
NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of
MustCompile -> empty
RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"
- ModuleNode _ _ _ ->
+ ModuleNode {} ->
case recomp of
UpToDate
| verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
@@ -742,7 +742,7 @@ hsunitModuleGraph do_link unit = do
-- requirement.
let hsig_set = Set.fromList
[ ms_mod_name ms
- | ModuleNode _ _ ms <- nodes
+ | ModuleNode _ _ _ ms <- nodes
, ms_hsc_src ms == HsigFile
]
req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->
@@ -817,7 +817,7 @@ summariseRequirement pn mod_name = do
ms_hspp_buf = Nothing
}
let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) todoStage (homeUnitId home_unit)) | mn <- extra_sig_imports ]
- return (ModuleNode nodes todoStage ms)
+ return (ModuleNode nodes [] todoStage ms)
summariseDecl :: PackageName
-> HscSource
@@ -935,7 +935,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
[k | (_, _, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) todoStage (moduleUnitId this_mod)), k `elem` home_keys]
- return (ModuleNode (mod_nodes ++ inst_nodes) todoStage ms)
+ return (ModuleNode (mod_nodes ++ inst_nodes) [] todoStage ms)
-- | Create a new, externally provided hashed unit id from
-- a hash.
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -258,7 +258,7 @@ instance Diagnostic DriverMessage where
go (m:ms) = (text "which imports" <+> ppr_node m) : go ms
ppr_node :: ModuleGraphNode -> SDoc
- ppr_node (ModuleNode _deps lvl m) = text "module" <+> ppr_ms m <+> text "@" <> ppr lvl
+ ppr_node (ModuleNode _deps _uids lvl m) = text "module" <+> ppr_ms m <+> text "@" <> ppr lvl
ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u
ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -831,7 +831,7 @@ hscRecompStatus
= do
let
msg what = case mHscMessage of
- Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] lvl mod_summary)
+ Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] [] lvl mod_summary)
Nothing -> return ()
-- First check to see if the interface file agrees with the
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -631,13 +631,13 @@ 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 _ lvl ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
+ [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ _ lvl ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules = mapMaybe (fmap fst . get_boot_module)
get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
- get_boot_module m = case m of ModuleNode _ lvl ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing
+ get_boot_module m = case m of ModuleNode _ _ lvl ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing
-- Any cycles should be resolved now
collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
@@ -1153,7 +1153,7 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
(hug, deps) <- wait_deps_hug hug_var build_deps
executeInstantiationNode mod_idx n_mods hug uid iu
return (Nothing, deps)
- ModuleNode _build_deps lvl ms ->
+ ModuleNode _build_deps _uids lvl ms ->
let !old_hmi = M.lookup (msKey lvl ms) old_hpt
rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes
in withCurrentUnit (moduleGraphNodeUnitId mod) $ do
@@ -1668,10 +1668,10 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
= loopSummaries next (done, summarised)
-- Didn't work out what the imports mean yet, now do that.
| otherwise = do
- (final_deps, done', summarised') <- loopImports (calcDeps lvl ms) done summarised
+ (final_deps, uids, done', summarised') <- loopImports (calcDeps lvl 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 lvl ms) done'', summarised'')
+ (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
+ loopSummaries next (M.insert k (ModuleNode final_deps uids lvl ms) done'', summarised'')
where
k = NodeKey_Module (msKey lvl ms)
@@ -1691,17 +1691,17 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
-- Visited set; the range is a list because
-- the roots can have the same module names
-- if allow_dup_roots is True
- -> IO ([NodeKey],
+ -> IO ([NodeKey], [(ModuleStage, UnitId)],
M.Map NodeKey ModuleGraphNode, DownsweepCache)
-- The result is the completed NodeMap
- loopImports [] done summarised = return ([], done, summarised)
+ loopImports [] done summarised = return ([], [], done, summarised)
loopImports ((home_uid, lvl, mb_pkg, gwib) : ss) done summarised
| Just summs <- M.lookup cache_key summarised
= case summs of
[Right ms] -> do
let nk = NodeKey_Module (msKey lvl ms)
- (rest, summarised', done') <- loopImports ss done summarised
- return (nk: rest, summarised', done')
+ (rest, uids, summarised', done') <- loopImports ss done summarised
+ return (nk: rest, uids, summarised', done')
[Left _err] ->
loopImports ss done summarised
_errs -> do
@@ -1713,20 +1713,20 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
Nothing excl_mods
case mb_s of
NotThere -> loopImports ss done summarised
- External _ -> do
- (other_deps, done', summarised') <- loopImports ss done summarised
- return (other_deps, done', summarised')
+ External uid -> do
+ (other_deps, uids, done', summarised') <- loopImports ss done summarised
+ return (other_deps, (lvl, uid):uids, done', summarised')
FoundInstantiation iud -> do
- (other_deps, done', summarised') <- loopImports ss done summarised
- return (NodeKey_Unit iud : other_deps, done', summarised')
+ (other_deps, uids, done', summarised') <- loopImports ss done summarised
+ return (NodeKey_Unit iud : other_deps, uids, done', summarised')
FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
FoundHome s -> do
(done', summarised') <-
loopSummaries [(lvl, s)] (done, Map.insert cache_key [Right s] summarised)
- (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
+ (other_deps, uids, 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 (NodeKey_Module (msKey lvl s) : other_deps, final_done, final_summarised)
+ return (NodeKey_Module (msKey lvl s) : other_deps, uids, final_done, final_summarised)
where
cache_key = (home_uid, lvl, mb_pkg, unLoc <$> gwib)
home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
@@ -1908,7 +1908,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 lvl ms)
+ enable_code_gen n@(ModuleNode deps uids lvl ms)
| ModSummary
{ ms_location = ms_location
, ms_hsc_src = HsSrcFile
@@ -1946,7 +1946,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 lvl ms')
+ enable_code_gen (ModuleNode deps uids lvl 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
@@ -1956,19 +1956,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 lvl ms')
+ enable_code_gen (ModuleNode deps uids lvl 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 lvl ms')
+ enable_code_gen (ModuleNode deps uids lvl 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 lvl ms')
+ enable_code_gen (ModuleNode deps uids lvl ms')
| otherwise -> return n
@@ -2047,7 +2047,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 lvl ms) <- mod_graph
+ | (ModuleNode deps uids lvl ms) <- mod_graph
, isTemplateHaskellOrQQNonBoot ms
, not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))
]
@@ -2056,7 +2056,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
need_bc_set =
concat
[ deps
- | (ModuleNode deps lvl ms) <- mod_graph
+ | (ModuleNode deps uids lvl ms) <- mod_graph
, isTemplateHaskellOrQQNonBoot ms
, gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)
]
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -222,7 +222,7 @@ processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
-processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ _ node))
+processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ _ _ node))
= do { let extra_suffixes = depSuffixes dflags
include_pkg_deps = depIncludePkgDeps dflags
src_file = msHsFilePath node
@@ -404,10 +404,10 @@ pprCycle :: [ModuleGraphNode] -> SDoc
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_mods = map (moduleName . ms_mod) [ms | ModuleNode _ _ _ ms <- summaries]
pp_group :: SCC ModuleGraphNode -> SDoc
- pp_group (AcyclicSCC (ModuleNode _ _ ms)) = pp_ms ms
+ pp_group (AcyclicSCC (ModuleNode _ _ _ ms)) = pp_ms ms
pp_group (AcyclicSCC _) = empty
pp_group (CyclicSCC mss)
= assert (not (null boot_only)) $
@@ -417,12 +417,12 @@ pprCycle summaries = pp_group (CyclicSCC summaries)
pp_ms 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 (\(_, _, m) -> m) (ms_imps ms)))
+ is_boot_only (ModuleNode _ _ _ ms) = not (any in_group (map (\(_, _, m) -> m) (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]
+ group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ _ _ ms <- mss]
- loop_breaker = head ([ms | ModuleNode _ _ ms <- boot_only])
+ loop_breaker = head ([ms | ModuleNode _ _ _ ms <- boot_only])
all_others = tail boot_only ++ others
groups =
GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -1276,7 +1276,7 @@ showModule mod_summary =
case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of
Nothing -> panic "missing linkable"
Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info)
- return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] todoStage mod_summary))
+ return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] [] todoStage mod_summary))
moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -461,6 +461,7 @@ tcRnImports hsc_env import_decls
-- filtering also ensures that we don't see instances from
-- modules batch (@--make@) compiled before this one, but
-- which are not below this one.
+
; (home_inst_bind_env, home_insts, home_fam_insts) =
hptInstancesBelow hsc_env unitId zeroStage mnwib
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -187,7 +187,7 @@ import GHC.Types.Unique.Set( elementOfUniqSet )
import GHC.Types.Name.Env
import GHC.Types.Id
-import GHC.Unit.Module ( HasModule, getModule, extractModule )
+import GHC.Unit.Module
import qualified GHC.Rename.Env as TcM
import GHC.Utils.Outputable
@@ -216,6 +216,8 @@ import GHC.Data.Graph.Directed
#endif
import qualified Data.Set as Set
+import qualified Data.Map as Map
+import GHC.Unit.Module.Graph
{- *********************************************************************
* *
@@ -1456,9 +1458,36 @@ checkWellStagedInstanceWhat what
cur_mod <- extractModule <$> getGblEnv
gbl_env <- getGblEnv
-- pprTraceM "checkWellStaged" (ppr what)
+ hsc_env <- getTopEnv
+ let tg = mkTransDepsZero (hsc_units hsc_env) (mgModSummaries' (hsc_mod_graph hsc_env))
+ let lkup s = flip (Map.!) (Left (ModNodeKeyWithUid (GWIB (moduleName cur_mod) NotBoot) zeroStage (moduleUnitId cur_mod), s)) tg
+ let splice_lvl = lkup SpliceStage
+ normal_lvl = lkup NormalStage
+ quote_lvl = lkup QuoteStage
+
+ name_module = nameModule (idName dfun_id)
+ instance_key = if moduleUnitId name_module `Set.member` hsc_all_home_unit_ids hsc_env
+ then Left (ModNodeKeyWithUid (GWIB (moduleName name_module) NotBoot) zeroStage (moduleUnitId name_module), NormalStage)
+ else Right (moduleUnitId name_module)
+
+ {- pprTraceM "instnace_key" (ppr instance_key)
+ pprTraceM "splice_lvl" (ppr (instance_key `Set.member` splice_lvl))
+ pprTraceM "splice_lvl" (ppr (instance_key `Set.member` normal_lvl))
+ pprTraceM "splice_lvl" (ppr (instance_key `Set.member` quote_lvl))
+ -}
+ let lvls = [ 0 | instance_key `Set.member` splice_lvl]
+ ++ [ 1 | instance_key `Set.member` normal_lvl ]
+ ++ [ 2 | instance_key `Set.member` quote_lvl ]
+
+ if isLocalId dfun_id
+ then return $ Just ( (Set.singleton outerLevel, True) )
+ else return $ Just ( Set.fromList lvls, False )
+
+
-- pprTraceM "checkWellStaged" (ppr (tcg_bind_env gbl_env))
-- pprTraceM "checkWellStaged"
-- (ppr (lookupNameEnv (tcg_bind_env gbl_env) (idName dfun_id)))
+-- {-
return $ (,isLocalId dfun_id) <$> (lookupNameEnv (tcg_bind_env gbl_env) (idName dfun_id))
return $ case lookupNameEnv (tcg_bind_env gbl_env) (idName dfun_id) of
-- The instance comes from HPT imported module
@@ -1470,6 +1499,7 @@ checkWellStagedInstanceWhat what
-- to deal with splice imports
else Just ( (Set.fromList [impLevel, outerLevel], False) )
-- return $ Just (TcM.topIdLvl dfun_id)
+-- -}
| BuiltinTypeableInstance tc <- what
= do
cur_mod <- extractModule <$> getGblEnv
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -25,16 +25,21 @@ module GHC.Unit.Module.Graph
, moduleGraphModulesBelow
, moduleGraphNodes
+ , moduleGraphNodesZero
, SummaryNode
, summaryNodeSummary
, NodeKey(..)
, nodeKeyUnitId
, nodeKeyModName
+ , nodeKeyLevel
, ModNodeKey
, mkNodeKey
, msKey
+ , mkTransDepsZero
+
+
, moduleGraphNodeUnitId
@@ -83,6 +88,8 @@ import Data.List (sort, nub)
import GHC.Data.List.SetOps
import GHC.Stack
import GHC.Utils.Panic
+import GHC.Unit.State
+import Language.Haskell.Syntax.ImpExp
-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
-- Edges between nodes mark dependencies arising from module imports
@@ -92,7 +99,7 @@ data ModuleGraphNode
-- (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] ModuleStage ModSummary
+ | ModuleNode [NodeKey] [(ModuleStage, UnitId)] ModuleStage ModSummary
-- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.
| LinkNode [NodeKey] UnitId
@@ -102,19 +109,19 @@ moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn)
moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary
moduleGraphNodeModSum (InstantiationNode {}) = Nothing
moduleGraphNodeModSum (LinkNode {}) = Nothing
-moduleGraphNodeModSum (ModuleNode _ _ ms) = Just ms
+moduleGraphNodeModSum (ModuleNode _ _ _ ms) = Just ms
moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId
moduleGraphNodeUnitId mgn =
case mgn of
InstantiationNode uid _iud -> uid
- ModuleNode _ _lvl ms -> toUnitId (moduleUnit (ms_mod ms))
+ ModuleNode _ _lvl _ ms -> toUnitId (moduleUnit (ms_mod ms))
LinkNode _ uid -> uid
instance Outputable ModuleGraphNode where
ppr = \case
InstantiationNode _ iuid -> ppr iuid
- ModuleNode nks lvl ms -> ppr (msKey lvl ms) <+> ppr nks
+ ModuleNode nks _ lvl ms -> ppr (msKey lvl ms) <+> ppr nks
LinkNode uid _ -> text "LN:" <+> ppr uid
instance Eq ModuleGraphNode where
@@ -141,6 +148,11 @@ nodeKeyUnitId (NodeKey_Unit iu) = instUnitInstanceOf iu
nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk
nodeKeyUnitId (NodeKey_Link uid) = uid
+nodeKeyLevel :: NodeKey -> ModuleStage
+nodeKeyLevel (NodeKey_Unit iud) = zeroStage
+nodeKeyLevel (NodeKey_Module mk) = mnkLevel mk
+nodeKeyLevel (NodeKey_Link uid) = zeroStage
+
nodeKeyModName :: NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk)
nodeKeyModName _ = Nothing
@@ -194,7 +206,7 @@ mapMG f mg at ModuleGraph{..} = mg
{ mg_mss = flip fmap mg_mss $ \case
InstantiationNode uid iuid -> InstantiationNode uid iuid
LinkNode uid nks -> LinkNode uid nks
- ModuleNode deps lvl ms -> ModuleNode deps lvl (f ms)
+ ModuleNode deps uid lvl ms -> ModuleNode deps uid lvl (f ms)
}
unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph
@@ -210,7 +222,7 @@ mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey)
mgTransDeps = mg_trans_deps
mgModSummaries :: ModuleGraph -> [ModSummary]
-mgModSummaries mg = [ m | ModuleNode _ _lvl m <- mgModSummaries' mg ]
+mgModSummaries mg = [ m | ModuleNode _ _ _lvl m <- mgModSummaries' mg ]
mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]
mgModSummaries' = mg_mss
@@ -222,7 +234,7 @@ mgModSummaries' = mg_mss
mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
where
- go (ModuleNode _ _lvl ms)
+ go (ModuleNode _ _ _lvl ms)
| NotBoot <- isBootSummary ms
, ms_mod ms == m
= Just ms
@@ -239,10 +251,10 @@ isTemplateHaskellOrQQNonBoot ms =
-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is
-- not an element of the ModuleGraph.
-extendMG :: ModuleGraph -> [NodeKey] -> ModuleStage -> ModSummary -> ModuleGraph
-extendMG ModuleGraph{..} deps lvl ms = ModuleGraph
- { mg_mss = ModuleNode deps lvl ms : mg_mss
- , mg_trans_deps = mkTransDeps (ModuleNode deps lvl ms : mg_mss)
+extendMG :: ModuleGraph -> [NodeKey] -> [(ModuleStage, UnitId)] -> ModuleStage -> ModSummary -> ModuleGraph
+extendMG ModuleGraph{..} deps uid lvl ms = ModuleGraph
+ { mg_mss = ModuleNode deps uid lvl ms : mg_mss
+ , mg_trans_deps = mkTransDeps (ModuleNode deps uid lvl ms : mg_mss)
}
mkTransDeps :: [ModuleGraphNode] -> Map.Map NodeKey (Set.Set NodeKey)
@@ -250,6 +262,11 @@ mkTransDeps mss =
let (gg, _lookup_node) = moduleGraphNodes False mss
in allReachable gg (mkNodeKey . node_payload)
+mkTransDepsZero :: UnitState -> [ModuleGraphNode] -> Map.Map (Either (ModNodeKeyWithUid, ImportStage) UnitId) (Set.Set (Either (ModNodeKeyWithUid, ImportStage) UnitId))
+mkTransDepsZero us mss =
+ let (gg, _lookup_node) = moduleGraphNodesZero us mss
+ in allReachable gg node_payload
+
extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
extendMGInst mg uid depUnitId = mg
{ mg_mss = InstantiationNode uid depUnitId : mg_mss mg
@@ -261,7 +278,7 @@ 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 lvl ms -> extendMG mg deps lvl ms
+ ModuleNode deps uid lvl ms -> extendMG mg deps uid lvl ms
LinkNode deps uid -> extendMGLink mg uid deps
mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
@@ -273,7 +290,7 @@ collapseModuleGraph = mkModuleGraph . collapseModuleGraphNodes . mgModSummaries'
collapseModuleGraphNodes :: [ModuleGraphNode] -> [ModuleGraphNode]
collapseModuleGraphNodes m = nub $ map go m
where
- go (ModuleNode deps _lvl ms) = ModuleNode (nub $ map collapseNodeKey deps) zeroStage ms
+ go (ModuleNode deps uid _lvl ms) = ModuleNode (nub $ map collapseNodeKey deps) uid zeroStage ms
go (LinkNode deps uid) = LinkNode (nub $ map collapseNodeKey deps) uid
go (InstantiationNode uid iuid) = InstantiationNode uid iuid
@@ -294,7 +311,7 @@ filterToposortToModules
filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
InstantiationNode _ _ -> Nothing
LinkNode{} -> Nothing
- ModuleNode _deps _lvl node -> Just node
+ ModuleNode _deps _uid _lvl node -> Just node
where
-- This higher order function is somewhat bogus,
-- as the definition of "strongly connected component"
@@ -319,7 +336,7 @@ showModMsg dflags _ (LinkNode {}) =
in text exe_file
showModMsg _ _ (InstantiationNode _uid indef_unit) =
ppr $ instUnitInstanceOf indef_unit
-showModMsg dflags recomp (ModuleNode _ lvl mod_summary) =
+showModMsg dflags recomp (ModuleNode _ _ lvl mod_summary) =
if gopt Opt_HideSourcePaths dflags
then text mod_str
else hsep $
@@ -365,7 +382,7 @@ nodeDependencies drop_hs_boot_nodes = \case
LinkNode deps _uid -> deps
InstantiationNode uid iuid ->
NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) zeroStage uid) <$> uniqDSetToList (instUnitHoles iuid)
- ModuleNode deps _lvl _ms ->
+ ModuleNode deps uid _lvl _ms ->
map drop_hs_boot deps
where
-- Drop hs-boot nodes by using HsSrcFile as the key
@@ -390,7 +407,7 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
where
go (s, key) =
case s of
- ModuleNode __deps _lvl ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes
+ ModuleNode __deps _uid _lvl ms | isBootSummary 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)
@@ -423,13 +440,103 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
out_edge_keys = mapMaybe lookup_key
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- IsBoot; else False
+
+
+type ZeroSummaryNode = Node Int (Either (ModNodeKeyWithUid, ImportStage) UnitId)
+
+zeroSummaryNodeKey :: ZeroSummaryNode -> Int
+zeroSummaryNodeKey = node_key
+
+zeroSummaryNodeSummary :: ZeroSummaryNode -> Either (ModNodeKeyWithUid, ImportStage) UnitId
+zeroSummaryNodeSummary = node_payload
+
+-- | Turn a list of graph nodes into an efficient queriable graph.
+-- The first boolean parameter indicates whether nodes corresponding to hs-boot files
+-- should be collapsed into their relevant hs nodes.
+--
+-- This graph only has edges between level-0 imports
+--
+--
+-- This query answers the question. If I am looking at level n in module M then which
+-- modules are visible?
+--
+-- If you are looking at level -1 then the reachable modules are those imported at splice and
+-- then any modules those modules import at zero. (Ie the zero scope for those modules)
+moduleGraphNodesZero ::
+ UnitState
+ -> [ModuleGraphNode]
+ -> (Graph ZeroSummaryNode, Either (ModNodeKeyWithUid, ImportStage) UnitId -> Maybe ZeroSummaryNode)
+moduleGraphNodesZero us summaries =
+ (graphFromEdgedVerticesUniq nodes, lookup_node)
+ where
+ -- Map from module to extra boot summary dependencies which need to be merged in
+ (nodes) = mapMaybe go numbered_summaries
+
+ where
+ go :: ((Either (ModuleGraphNode, ImportStage) (UnitId, [UnitId])), Int) -> Maybe ZeroSummaryNode
+ go (s, key) = normal_case s
+ where
+ normal_case :: Either (ModuleGraphNode, ImportStage) (UnitId, [UnitId]) -> Maybe ZeroSummaryNode
+ normal_case (Left ((ModuleNode nks uids lvl ms), s)) = Just $
+ DigraphNode (Left (msKey lvl ms, s)) key $ out_edge_keys (jimmy_lvl lvl s) $
+ ((map Left $ only_module_deps nks)
+ ++ (map Right uids))
+ normal_case (Right (u, us)) =
+ Just $ DigraphNode (Right u) key (mapMaybe lookup_key $ map Right us)
+ normal_case _ = Nothing
+
+ only_module_deps ds = pprTraceIt "only_module" [ k | NodeKey_Module k <- ds ]
+
+ jimmy_lvl l s = case s of
+ NormalStage -> l
+ QuoteStage -> incModuleStage l
+ SpliceStage -> decModuleStage l
+
+ numbered_summaries :: [(Either (ModuleGraphNode, ImportStage) (UnitId, [UnitId]), Int)]
+ numbered_summaries = zip (([Left (s, l) | s <- summaries, l <- [SpliceStage, QuoteStage, NormalStage]]) ++ map Right (Map.toList all_unit_depends)) [1..]
+
+ all_unit_depends :: Map.Map UnitId [UnitId]
+ all_unit_depends = foldr (\m cache -> go cache (unit_depends m)) Map.empty summaries
+ where
+
+ go cache [] = cache
+ go cache (u:uxs) =
+ case Map.lookup u cache of
+ Just {} -> cache
+ Nothing -> case unitDepends <$> lookupUnitId us u of
+ Just us -> go (go (Map.insert u us cache) us) uxs
+ Nothing -> panic "bad"
+
+
+ unit_depends :: ModuleGraphNode -> [UnitId]
+ unit_depends (ModuleNode _ uids _ _) = map snd $ filter ((== zeroStage) . fst) uids
+ unit_depends _ = []
+
+ lookup_node :: Either (ModNodeKeyWithUid, ImportStage) UnitId -> Maybe ZeroSummaryNode
+ lookup_node key = Map.lookup key node_map
+
+ lookup_key :: Either (ModNodeKeyWithUid, ImportStage) UnitId -> Maybe Int
+ lookup_key = fmap zeroSummaryNodeKey . lookup_node
+
+ node_map :: Map.Map (Either (ModNodeKeyWithUid, ImportStage) UnitId) ZeroSummaryNode
+ node_map =
+ Map.fromList [ (s, node)
+ | node <- nodes
+ , let s = zeroSummaryNodeSummary node
+ ]
+
+ out_edge_keys :: ModuleStage -> [Either ModNodeKeyWithUid (ModuleStage, UnitId)] -> [Int]
+ out_edge_keys m = mapMaybe lookup_key . map (bimap (, NormalStage) snd) . filter (either (\nk -> mnkLevel nk == m) ((== m) . fst))
+ -- If we want keep_hi_boot_nodes, then we do lookup_key with
+ -- IsBoot; else False
+
newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
deriving (Functor, Traversable, Foldable)
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
InstantiationNode _ iu -> NodeKey_Unit iu
- ModuleNode _ lvl x -> NodeKey_Module $ msKey lvl x
+ ModuleNode _ _ lvl x -> NodeKey_Module $ msKey lvl x
LinkNode _ uid -> NodeKey_Link uid
msKey :: ModuleStage -> ModSummary -> ModNodeKeyWithUid
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -1748,7 +1748,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 $ isLoadedModSummary x
hasFailed _ = return False
graph <- GHC.getModuleGraph
@@ -2200,7 +2200,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do
(m:_) ->
load_this m
where
- is_loaded (GHC.ModuleNode _ _ ms) = isLoadedModSummary ms
+ is_loaded (GHC.ModuleNode _ _ _ ms) = isLoadedModSummary ms
is_loaded _ = return False
findTarget mds t
@@ -2208,9 +2208,9 @@ setContextAfterLoad keep_ctxt (Just graph) = do
[] -> Nothing
(m:_) -> Just m
- (GHC.ModuleNode _ _ summary) `matches` Target { targetId = TargetModule m }
+ (GHC.ModuleNode _ _ _ summary) `matches` Target { targetId = TargetModule m }
= if GHC.ms_mod_name summary == m then Just summary else Nothing
- (GHC.ModuleNode _ _ summary) `matches` Target { targetId = TargetFile f _ }
+ (GHC.ModuleNode _ _ _ summary) `matches` Target { targetId = TargetFile f _ }
| Just f' <- GHC.ml_hs_file (GHC.ms_location summary) =
if f == f' then Just summary else Nothing
_ `matches` _ = Nothing
=====================================
utils/haddock/haddock-api/src/Haddock/Interface.hs
=====================================
@@ -223,7 +223,7 @@ createIfaces verbosity modules flags instIfaceMap = do
-- but if module A {-# SOURCE #-} imports B, then we can't say the same.
--
let
- go (AcyclicSCC (ModuleNode _ _ ms))
+ go (AcyclicSCC (ModuleNode _ _ _ ms))
| NotBoot <- isBootSummary ms = [ms]
| otherwise = []
go (AcyclicSCC _) = []
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/448086cf11757197607b892c24b4c40622dd332f...3e18b3d7eb33dc964df728ab18bb10e5853dbeaa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/448086cf11757197607b892c24b4c40622dd332f...3e18b3d7eb33dc964df728ab18bb10e5853dbeaa
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/20241031/e79dd9f4/attachment-0001.html>
More information about the ghc-commits
mailing list