[Git][ghc/ghc][wip/splice-imports-2024] 3 commits: updates
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Nov 15 16:19:21 UTC 2024
Matthew Pickering pushed to branch wip/splice-imports-2024 at Glasgow Haskell Compiler / GHC
Commits:
a1911613 by Matthew Pickering at 2024-11-12T12:19:54+00:00
updates
- - - - -
d568b6f2 by Matthew Pickering at 2024-11-13T09:11:30+00:00
Resolve confusion about level vs stage
- - - - -
eaf0f1b0 by Matthew Pickering at 2024-11-15T16:18:43+00:00
nubORd
- - - - -
24 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Expr.hs-boot
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Unit/Module/Graph.hs
- ghc/GHCi/UI.hs
- + testsuite/tests/splice-imports/SI22.stderr
- + testsuite/tests/splice-imports/SI23.hs
- + testsuite/tests/splice-imports/SI23A.hs
- + testsuite/tests/splice-imports/SI24.hs
- testsuite/tests/splice-imports/all.T
- utils/haddock/haddock-api/src/Haddock/Interface.hs
Changes:
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -589,6 +589,7 @@ mkBackpackMsg = do
MustCompile -> empty
RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"
LinkNode _ _ -> showMsg (text "Linking ") empty
+ UnitNode _ _ uid -> showMsg (text "Existing dependency" <+> ppr uid) empty
-- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not
@@ -742,7 +743,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, _) ->
@@ -816,8 +817,8 @@ summariseRequirement pn mod_name = do
ms_hspp_opts = dflags,
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)
+ let nodes = [(NormalStage, NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) todoStage (homeUnitId home_unit))) | mn <- extra_sig_imports ]
+ return (ModuleNode nodes todoStage ms)
summariseDecl :: PackageName
-> HscSource
@@ -935,7 +936,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 (map (NormalStage,) (mod_nodes ++ inst_nodes)) todoStage ms)
-- | Create a new, externally provided hashed unit id from
-- a hash.
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -81,7 +81,6 @@ import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Logger
-import GHC.Tc.Types.TH
import Data.List
@@ -236,18 +235,17 @@ hptAllInstances hsc_env
in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)
-- | Find instances visible from the given set of imports
-hptInstancesBelow :: HscEnv -> UnitId -> ModuleStage -> ModuleNameWithIsBoot -> (NameEnv (Set.Set ThLevel), InstEnv, [FamInst])
+hptInstancesBelow :: HscEnv -> UnitId -> ModuleStage -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])
hptInstancesBelow hsc_env uid lvl mnwib =
let
- mk_bind_env clvl ie = mkNameEnv $ flip zip (repeat (Set.singleton (moduleStageToThLevel clvl))) $ map is_dfun_name (instEnvElts ie)
mn = gwib_mod mnwib
- (bind_env, insts, famInsts) =
- unzip3 $ hptSomeThingsBelowUs (\mlvl mod_info ->
+ (insts, famInsts) =
+ unzip $ hptSomeThingsBelowUs (\_mlvl mod_info ->
let details = hm_details mod_info
-- Don't include instances for the current module
in if moduleName (mi_module (hm_iface mod_info)) == mn
then []
- else [(mk_bind_env mlvl (md_insts details), md_insts details, md_fam_insts details)])
+ else [(md_insts details, md_fam_insts details)])
True -- Include -hi-boot
hsc_env
uid
@@ -255,7 +253,7 @@ hptInstancesBelow hsc_env uid lvl mnwib =
mnwib
-- Horrible horrible
hack = mkInstEnv (nubBy (\c1 c2 -> instanceDFunId c1 == instanceDFunId c2) (concatMap instEnvElts insts))
- in ((foldl' (plusNameEnv_C Set.union) emptyNameEnv bind_env), hack, concat famInsts)
+ in (hack, concat famInsts)
-- | Get rules from modules "below" this one (in the dependency sense)
hptRules :: HscEnv -> UnitId -> ModuleStage -> ModuleNameWithIsBoot -> [CoreRule]
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -258,10 +258,11 @@ instance Diagnostic DriverMessage where
go (m:ms) = (text "which imports" <+> ppr_node m) : go ms
ppr_node :: ModuleGraphNode -> SDoc
- ppr_node (ModuleNode _deps _uids lvl m)
+ ppr_node (ModuleNode _deps lvl m)
= text "module" <+> ppr_ms m <+> if lvl == zeroStage then empty else (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)
+ ppr_node (UnitNode _ _ uid) = pprPanic "UnitNode not in cycle" (ppr uid)
ppr_ms :: ModSummary -> SDoc
ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
=====================================
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
@@ -1469,6 +1469,7 @@ batchMsgWith extra hsc_env_start mod_index recomp node =
LinkNode {} -> "Linking"
InstantiationNode {} -> "Instantiating"
ModuleNode {} -> "Compiling"
+ UnitNode {} -> "Using"
hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -611,12 +611,11 @@ createBuildPlan mod_graph maybe_top_mod =
mresolved_cycle = collapseSCC (topSortWithBoot nodes)
in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []
- (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)
- trans_deps_map = allReachable mg (mkNodeKey . node_payload)
+ (trans_deps_map, lookup_node) = mgTransDeps mod_graph
-- Compute the intermediate modules between a file and its hs-boot file.
-- See Step 2a in Note [Upsweep]
boot_path mn uid =
- map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $
+ map (expectJust "toNode" . lookup_node) $ Set.toList $
-- Don't include the boot module itself
Set.delete (NodeKey_Module (key IsBoot)) $
-- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are
@@ -631,13 +630,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 +1152,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 _uids lvl ms ->
+ ModuleNode _build_deps lvl ms ->
let !old_hmi = M.lookup (msKey lvl ms) old_hpt
rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes
in withCurrentUnit (moduleGraphNodeUnitId mod) $ do
@@ -1171,6 +1170,9 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
(hug, deps) <- wait_deps_hug hug_var build_deps
executeLinkNode hug (mod_idx, n_mods) uid direct_deps
return (Nothing, deps)
+ UnitNode {} ->
+ -- TODO: Perhaps can prelink in these units here
+ return (Nothing, M.empty)
res_var <- liftIO newEmptyMVar
@@ -1478,14 +1480,14 @@ topSortModuleGraph
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 (reverse $ collapseModuleGraphNodes $ mgModSummaries' module_graph) mb_root_mod
+ topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod
topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModules drop_hs_boot_nodes summaries mb_root_mod
= map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
where
(graph, lookup_node) =
- moduleGraphNodes drop_hs_boot_nodes summaries
+ moduleGraphNodes drop_hs_boot_nodes CollapseToZero summaries
initial_graph = case mb_root_mod of
Nothing -> graph
@@ -1617,7 +1619,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
-- for dependencies of modules that have -XTemplateHaskell,
-- otherwise those modules will fail to compile.
-- See Note [-fno-code mode] #8025
- th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env (hsc_units hsc_env) all_nodes
+ th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes
if null all_root_errs
then return (all_errs, th_enabled_nodes)
else pure $ (all_root_errs, [])
@@ -1633,11 +1635,9 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
-- Add a dependency on the HsBoot file if it exists
-- This gets passed to the loopImports function which just ignores it if it
-- can't be found.
- [(ms_unitid ms, lvl, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
- [(ms_unitid ms, offsetStage lvl st, b, c) | (st, b, c) <- msDeps ms ]
+ [(ms_unitid ms, NormalStage, lvl, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
+ [(ms_unitid ms, st, offsetStage lvl st, b, c) | (st, b, c) <- msDeps ms ]
- -- Hacky..
- offsetStage lvl _ | lvl >= ModuleStage 10 || lvl <= ModuleStage (-10) = lvl
offsetStage lvl NormalStage = lvl
offsetStage lvl QuoteStage = incModuleStage lvl
offsetStage lvl SpliceStage = decModuleStage lvl
@@ -1670,10 +1670,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, uids, done', summarised') <- loopImports (calcDeps lvl ms) done summarised
+ (final_deps, 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 (maybeToList zero ++ next) (M.insert k (ModuleNode final_deps (ordNub uids) lvl ms) done'', summarised'')
+ (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
+ loopSummaries (maybeToList zero ++ next) (M.insert k (ModuleNode final_deps lvl ms) done'', summarised'')
where
k = NodeKey_Module (msKey lvl ms)
@@ -1683,31 +1683,31 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
hs_file_for_boot
| HsBootFile <- ms_hsc_src ms
- = Just $ ((ms_unitid ms), lvl, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
+ = Just $ ((ms_unitid ms), NormalStage, lvl, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
| otherwise
= Nothing
-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
-- a new module by doing this.
- loopImports :: [(UnitId, ModuleStage, PkgQual, GenWithIsBoot (Located ModuleName))]
+ loopImports :: [(UnitId, ImportStage, ModuleStage, PkgQual, GenWithIsBoot (Located ModuleName))]
-- Work list: process these modules
-> M.Map NodeKey ModuleGraphNode
-> DownsweepCache
-- Visited set; the range is a list because
-- the roots can have the same module names
-- if allow_dup_roots is True
- -> IO ([NodeKey], [(ModuleStage, UnitId)],
+ -> IO ([(ImportStage, NodeKey)],
M.Map NodeKey ModuleGraphNode, DownsweepCache)
-- The result is the completed NodeMap
- loopImports [] done summarised = return ([], [], done, summarised)
- loopImports ((home_uid, lvl, mb_pkg, gwib) : ss) done summarised
+ loopImports [] done summarised = return ([], done, summarised)
+ loopImports ((home_uid, imp, 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, uids, summarised', done') <- loopImports ss done summarised
- return (nk: rest, uids, summarised', done')
+ let nk = (imp, NodeKey_Module (msKey lvl ms))
+ (rest, summarised', done') <- loopImports ss done summarised
+ return (nk: rest, summarised', done')
[Left _err] ->
loopImports ss done summarised
_errs -> do
@@ -1720,25 +1720,36 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
case mb_s of
NotThere -> loopImports ss done summarised
External uid -> do
- (other_deps, uids, done', summarised') <- loopImports ss done summarised
- return (other_deps, (lvl, uid):uids, done', summarised')
+ let done' = loopUnit done [(lvl, uid)]
+ (other_deps, done'', summarised') <- loopImports ss done' summarised
+ return ((imp, NodeKey_ExternalUnit lvl uid) : other_deps, done'', summarised')
FoundInstantiation iud -> do
- (other_deps, uids, done', summarised') <- loopImports ss done summarised
- return (NodeKey_Unit iud : other_deps, uids, done', summarised')
+ (other_deps, done', summarised') <- loopImports ss done summarised
+ return ((imp, NodeKey_Unit iud) : other_deps, done', summarised')
FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
FoundHome s -> do
(done', summarised') <-
loopSummaries [(lvl, s)] (done, Map.insert cache_key [Right s] summarised)
- (other_deps, uids, final_done, final_summarised) <- loopImports ss done' summarised'
+ (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
-- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
- return (NodeKey_Module (msKey lvl s) : other_deps, uids, final_done, final_summarised)
+ return ((imp, NodeKey_Module (msKey lvl s)) : other_deps, 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)
GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
wanted_mod = L loc mod
+ loopUnit :: Map.Map NodeKey ModuleGraphNode -> [(ModuleStage, UnitId)] -> Map.Map NodeKey ModuleGraphNode
+ loopUnit cache [] = cache
+ loopUnit cache ((lvl, u):uxs) = do
+ let nk = (NodeKey_ExternalUnit lvl u)
+ case Map.lookup nk cache of
+ Just {} -> loopUnit cache uxs
+ Nothing -> case unitDepends <$> lookupUnitId (hsc_units hsc_env) u of
+ Just us -> loopUnit (loopUnit (Map.insert nk (UnitNode us lvl u) cache) (zip (repeat lvl) us)) uxs
+ Nothing -> panic "bad"
+
getRootSummary ::
[ModuleName] ->
M.Map (UnitId, FilePath) ModSummary ->
@@ -1884,11 +1895,10 @@ enableCodeGenForTH
:: Logger
-> TmpFs
-> UnitEnv
- -> UnitState
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
-enableCodeGenForTH logger tmpfs unit_env unit_state =
- enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env unit_state
+enableCodeGenForTH logger tmpfs unit_env =
+ enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env
data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord)
@@ -1908,15 +1918,14 @@ enableCodeGenWhen
-> TempFileLifetime
-> TempFileLifetime
-> UnitEnv
- -> UnitState
-> [ModuleGraphNode]
-> IO [ModuleGraphNode]
-enableCodeGenWhen logger tmpfs staticLife dynLife unit_env unit_state mod_graph =
+enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
mapM enable_code_gen mod_graph
where
defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)
enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
- enable_code_gen n@(ModuleNode deps uids lvl ms)
+ enable_code_gen n@(ModuleNode deps lvl ms)
| ModSummary
{ ms_location = ms_location
, ms_hsc_src = HsSrcFile
@@ -1954,7 +1963,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env unit_state mod_graph
, ms_hspp_opts = updOptLevel 0 $ new_dflags
}
-- Recursive call to catch the other cases
- enable_code_gen (ModuleNode deps uids lvl ms')
+ enable_code_gen (ModuleNode deps 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
@@ -1964,19 +1973,19 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env unit_state 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 uids lvl ms')
+ enable_code_gen (ModuleNode deps 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 uids lvl ms')
+ enable_code_gen (ModuleNode deps 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 uids lvl ms')
+ enable_code_gen (ModuleNode deps lvl ms')
| otherwise -> return n
@@ -2031,7 +2040,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env unit_state mod_graph
lcl_dflags = ms_hspp_opts ms
internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
- (mg, lookup_node) = moduleGraphNodesZero unit_state mod_graph
+ (mg, lookup_node) = moduleGraphNodesZero mod_graph
mk_needed_set roots = Set.fromList $ map fst $ lefts $ map node_payload $ reachablesG2 mg (map (expectJust "needs_th" . lookup_node) (map Left roots))
@@ -2057,7 +2066,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env unit_state mod_graph
-- Note we don't need object code for a module if it uses TemplateHaskell itself. Only
-- it's dependencies.
[ (msKey lvl ms, code_stage ms)
- | (ModuleNode _deps _uids lvl ms) <- mod_graph
+ | (ModuleNode _deps lvl ms) <- mod_graph
, isTemplateHaskellOrQQNonBoot ms
, not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))
]
@@ -2065,7 +2074,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env unit_state mod_graph
-- The direct dependencies of modules which require byte code
need_bc_set =
[ (msKey lvl ms, code_stage ms)
- | (ModuleNode _deps _uids lvl ms) <- mod_graph
+ | (ModuleNode _deps lvl ms) <- mod_graph
, isTemplateHaskellOrQQNonBoot ms
, gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)
]
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -221,8 +221,9 @@ processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node
processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
+processDeps _ _ _ _ _ (AcyclicSCC (UnitNode {})) = 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 +405,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 +418,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/Linker/Deps.hs
=====================================
@@ -165,7 +165,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
make_deps_loop found@(found_units, found_mods) (nk:nexts)
| NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
| otherwise =
- case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of
+ case M.lookup (NodeKey_Module nk) (fst $ mgTransDeps mod_graph) of
Just trans_deps ->
let deps = Set.insert (NodeKey_Module nk) trans_deps
-- See #936 and the ghci.prog007 test for why we have to continue traversing through
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -111,7 +111,6 @@ import System.Win32.Info (getSystemDirectory)
#endif
import GHC.Utils.Exception
-import GHC.Unit.Module.Graph
-- Note [Linkers and loaders]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -644,7 +643,7 @@ initLinkDepsOpts hsc_env = opts
-- MP: This is very inefficient as it destroys sharing of
-- calculating transitive dependencies. it would be better if we
-- were explicit about requesting modules at a specific stage.
- , ldModuleGraph = collapseModuleGraph $ hsc_mod_graph hsc_env
+ , ldModuleGraph = hsc_mod_graph hsc_env
, ldUnitEnv = hsc_unit_env hsc_env
, ldPprOpts = initSDocContext dflags defaultUserStyle
, ldFinderCache = hsc_FC hsc_env
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4045,6 +4045,9 @@ special_id
| 'unit' { sL1 $1 (fsLit "unit") }
| 'dependency' { sL1 $1 (fsLit "dependency") }
| 'signature' { sL1 $1 (fsLit "signature") }
+ | 'quote' { sL1 $1 (fsLit "quote") }
+ | 'splice' { sL1 $1 (fsLit "splice") }
+
special_sym :: { Located FastString }
special_sym : '.' { sL1 $1 (fsLit ".") }
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -304,16 +304,7 @@ rnExprs ls = rnExprs' ls emptyUniqSet
rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
rnLExpr = wrapLocFstMA rnExpr
-rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-
-finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
--- Separated from rnExpr because it's also used
--- when renaming infix expressions
-finishHsVar (L l name)
- = do { --this_mod <- getModule
--- ; when (nameIsLocalOrFrom this_mod name) $
- ; checkThLocalName name
- ; return (HsVar noExtField (L (l2l l) name), unitFV name) }
+rnExpr :: HasCallStack=>HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar v = do
@@ -336,9 +327,7 @@ rnExpr (HsVar _ (L l v))
-- matching GRE and add a name clash error
-- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn).
-> do { let sel_name = flSelector $ recFieldLabel fld_info
- ; this_mod <- getModule
- ; when (nameIsLocalOrFrom this_mod sel_name) $
- checkThLocalName sel_name
+ ; unless (isExact v || isOrig v) $ checkThLocalName sel_name
; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name)
}
| nm == nilDataConName
@@ -349,9 +338,13 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> finishHsVar (L (l2l l) nm)
+ -> do { --pprTraceM "name" (ppr v $$ ppr (isOrig v) $$ ppr (isExact v))
+ ; unless (isExact v || isOrig v) (checkThLocalName nm)
+ ; return (HsVar noExtField (L (l2l l) nm), unitFV nm) }
+
}}}
+
rnExpr (HsIPVar x v)
= return (HsIPVar x v, emptyFVs)
=====================================
compiler/GHC/Rename/Expr.hs-boot
=====================================
@@ -6,8 +6,9 @@ import GHC.Hs
import GHC.Types.Name.Set ( FreeVars )
import GHC.Tc.Types
import GHC.Utils.Outputable ( Outputable )
+import GHC.Stack
-rnExpr :: HsExpr GhcPs
+rnExpr :: HasCallStack => HsExpr GhcPs
-> RnM (HsExpr GhcRn, FreeVars)
rnLExpr :: LHsExpr GhcPs
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -71,6 +71,7 @@ import qualified GHC.Internal.TH.Syntax as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
import qualified Data.Set as Set
+import GHC.Stack
{-
************************************************************************
@@ -525,7 +526,7 @@ rnUntypedSpliceExpr splice
-- mod_finalizers: See Note [Delaying modFinalizers in untyped splices].
-- Rename the expanded expression
- ; (L l expr_rn, fvs) <- setXOptM LangExt.PathCrossStagedPersistence $ checkNoErrs (rnLExpr expr_ps)
+ ; (L l expr_rn, fvs) <- checkNoErrs (rnLExpr expr_ps)
-- rn_splice :: HsUntypedSplice GhcRn is the original TH expression,
-- before expansion
@@ -911,7 +912,7 @@ data SpliceInfo
-- Note that 'spliceSource' is *renamed* but not *typechecked*
-- Reason (a) less typechecking crap
-- (b) data constructors after type checking have been
- -- changed to their *wrappers*, and that makes them
+ -- changed to their *wrapp----------------ers*, and that makes them
-- print always fully qualified
-- | outputs splice information for 2 flags which have different output formats:
@@ -973,8 +974,9 @@ checkThLocalTyName name
; dflags <- getDynFlags
; checkCrossStageLiftingTy dflags top_lvl bind_lvl use_stage use_lvl name } } }
-checkThLocalName :: Name -> RnM ()
+checkThLocalName :: HasCallStack => Name -> RnM ()
checkThLocalName name
+-- | pprTrace "checkTh" (ppr name $$ callStackDoc) False = undefined
| isUnboundName name -- Do not report two errors for
= return () -- $(not_in_scope args)
@@ -1032,7 +1034,7 @@ checkCrossStageLifting dflags reason top_lvl is_local bind_lvl use_stage use_lvl
, xopt LangExt.PathCrossStagedPersistence dflags = return ()
| not is_local
, xopt LangExt.PathCrossStagedPersistence dflags = return ()
- | otherwise = failWithTc (TcRnBadlyStaged reason bind_lvl use_lvl)
+ | otherwise = addErrTc (TcRnBadlyStaged reason bind_lvl use_lvl)
check_cross_stage_lifting :: TcRnMessage -> DynFlags -> TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
check_cross_stage_lifting reason dflags top_lvl name ps_var
=====================================
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
=====================================
@@ -462,7 +462,7 @@ tcRnImports hsc_env import_decls
-- modules batch (@--make@) compiled before this one, but
-- which are not below this one.
- ; (home_inst_bind_env, home_insts, home_fam_insts) =
+ ; (home_insts, home_fam_insts) =
hptInstancesBelow hsc_env unitId zeroStage mnwib
@@ -481,7 +481,7 @@ tcRnImports hsc_env import_decls
; updGblEnv ( \ gbl ->
gbl {
tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
- tcg_bind_env = tcg_bind_env gbl `plusNameEnv` home_inst_bind_env,
+ tcg_bind_env = tcg_bind_env gbl,
tcg_imports = tcg_imports gbl `plusImportAvails` imports,
tcg_import_decls = imp_user_spec,
tcg_rn_imports = rn_imports,
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -217,8 +217,8 @@ import qualified Data.Set as Set
import GHC.Unit.Module.Graph
import Data.Bifunctor (bimap)
-import GHC.Data.Graph.Directed
import GHC.Data.Maybe
+import qualified Data.Map as Map
{- *********************************************************************
* *
@@ -1458,10 +1458,13 @@ checkWellStagedInstanceWhat what
= do
cur_mod <- extractModule <$> getGblEnv
hsc_env <- getTopEnv
- let (mg, lookup_node) = moduleGraphNodesZero (hsc_units hsc_env) (mgModSummaries' $ hsc_mod_graph hsc_env)
+ let mg = mgTransDepsZero (hsc_mod_graph hsc_env)
let lkup :: ImportStage -> Set.Set (Either Module UnitId)
- lkup s = Set.fromList $ map (bimap (\(ModNodeKeyWithUid mn _ u,_) -> mkModule (RealUnit (Definite u)) (gwib_mod mn)) id . node_payload) $ reachablesG2 mg (map (expectJust "needs_th" . lookup_node) [Left (ModNodeKeyWithUid (GWIB (moduleName cur_mod) NotBoot) zeroStage (moduleUnitId cur_mod), s)])
+ lkup s =
+ let l1 = expectJust "checkWell" $ Map.lookup (Left (ModNodeKeyWithUid (GWIB (moduleName cur_mod) NotBoot) zeroStage (moduleUnitId cur_mod), s)) mg
+ in Set.map (bimap (\(ModNodeKeyWithUid mn _ u,_) -> mkModule (RealUnit (Definite u)) (gwib_mod mn)) id) l1
+ --Set.fromList $ map (bimap (\(ModNodeKeyWithUid mn _ u,_) -> mkModule (RealUnit (Definite u)) (gwib_mod mn)) id . node_payload) $
-- let lkup s = Set.map (bimap (\(ModNodeKeyWithUid mn _ u,_) -> mkModule (RealUnit (Definite u)) (gwib_mod mn)) id) $ flip (Map.!) (Left (ModNodeKeyWithUid (GWIB (moduleName cur_mod) NotBoot) zeroStage (moduleUnitId cur_mod), s)) tg
let splice_lvl = lkup SpliceStage
normal_lvl = lkup NormalStage
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -60,7 +60,7 @@ module GHC.Tc.Utils.Env(
-- Template Haskell stuff
StageCheckReason(..),
- checkWellStaged, tcMetaTy, thLevel,
+ tcMetaTy, thLevel,
topIdLvl, isBrackStage,
-- New Ids
@@ -139,7 +139,6 @@ import Control.Monad
import GHC.Iface.Errors.Types
import GHC.Types.Error
import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
-import qualified Data.Set as Set
{- *********************************************************************
* *
@@ -850,22 +849,6 @@ tcExtendRules lcl_rules thing_inside
************************************************************************
-}
--- MP: This whole function needs rewriting
-checkWellStaged :: StageCheckReason -- What the stage check is for
- -> Set.Set ThLevel -- Binding level (increases inside brackets)
- -> ThLevel -- Use stage
- -> TcM () -- Fail if badly staged, adding an error
-checkWellStaged pp_thing bind_lvl use_lvl
- | any (use_lvl >=) (Set.toList bind_lvl) -- OK! Used later than bound
- = return () -- E.g. \x -> [| $(f x) |]
-
- -- | bind_lvl == outerLevel -- GHC restriction on top level splices
- -- = failWithTc (TcRnStageRestriction pp_thing)
-
- | otherwise -- Badly staged
- = failWithTc $ -- E.g. \x -> $(f x)
- TcRnBadlyStaged pp_thing bind_lvl use_lvl
-
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
-- (separated by declaration splices) of this module. The former
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -8,9 +8,8 @@ module GHC.Unit.Module.Graph
, nodeDependencies
, emptyMG
, mkModuleGraph
- , extendMG
, extendMGInst
- , extendMG'
+ , extendModGraph
, unionMG
, isTemplateHaskellOrQQNonBoot
, isExplicitStageMS
@@ -20,6 +19,8 @@ module GHC.Unit.Module.Graph
, mgModSummaries'
, mgLookupModule
, mgTransDeps
+ , CollapseToZero(..)
+ , mgTransDepsZero
, showModMsg
, moduleGraphNodeModule
, moduleGraphNodeModSum
@@ -46,10 +47,11 @@ module GHC.Unit.Module.Graph
, ModNodeKeyWithUid(..)
- , ModuleStage(..)
+ , ModuleStage
+ , minStage
+ , maxStage
, zeroStage
, todoStage
- , moduleStageToThLevel
, incModuleStage
, decModuleStage
, collapseModuleGraph
@@ -85,12 +87,11 @@ import GHC.Linker.Static.Utils
import Data.Bifunctor
import Data.Function
-import Data.List (sort, nub)
+import Data.List (sort)
import GHC.Data.List.SetOps
import GHC.Stack
-import GHC.Utils.Panic
-import GHC.Unit.State
import Language.Haskell.Syntax.ImpExp
+import Data.Containers.ListUtils
-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
-- Edges between nodes mark dependencies arising from module imports
@@ -100,9 +101,11 @@ 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, UnitId)] ModuleStage ModSummary
+ | ModuleNode [(ImportStage, NodeKey)] ModuleStage ModSummary
-- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.
| LinkNode [NodeKey] UnitId
+ -- Unit nodes are already built, but show the structure of packages
+ | UnitNode [UnitId] ModuleStage UnitId
moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName
moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn)
@@ -110,20 +113,23 @@ 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
+moduleGraphNodeModSum (UnitNode {}) = Nothing
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
+ UnitNode _ _ uid -> uid
instance Outputable ModuleGraphNode where
ppr = \case
InstantiationNode _ iuid -> ppr iuid
- ModuleNode nks uids lvl ms -> ppr (msKey lvl ms) <+> ppr nks <+> ppr uids
+ ModuleNode nks lvl ms -> ppr (msKey lvl ms) <+> ppr nks
LinkNode uid _ -> text "LN:" <+> ppr uid
+ UnitNode uids st uid -> text "UN:" <+> ppr st <+> ppr uid <+> text "depends on" <+> ppr uids
instance Eq ModuleGraphNode where
(==) = (==) `on` mkNodeKey
@@ -134,6 +140,7 @@ instance Ord ModuleGraphNode where
data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit
| NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid
| NodeKey_Link !UnitId
+ | NodeKey_ExternalUnit !ModuleStage !UnitId
deriving (Eq, Ord)
instance Outputable NodeKey where
@@ -143,39 +150,51 @@ pprNodeKey :: NodeKey -> SDoc
pprNodeKey (NodeKey_Unit iu) = ppr iu
pprNodeKey (NodeKey_Module mk) = ppr mk
pprNodeKey (NodeKey_Link uid) = ppr uid
+pprNodeKey (NodeKey_ExternalUnit _ uid) = text "E:" <+> ppr uid
nodeKeyUnitId :: NodeKey -> UnitId
nodeKeyUnitId (NodeKey_Unit iu) = instUnitInstanceOf iu
nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk
nodeKeyUnitId (NodeKey_Link uid) = uid
+nodeKeyUnitId (NodeKey_ExternalUnit _ uid) = uid
nodeKeyLevel :: NodeKey -> ModuleStage
nodeKeyLevel (NodeKey_Unit {}) = zeroStage
nodeKeyLevel (NodeKey_Module mk) = mnkLevel mk
nodeKeyLevel (NodeKey_Link {}) = zeroStage
+nodeKeyLevel (NodeKey_ExternalUnit {}) = zeroStage
nodeKeyModName :: NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk)
nodeKeyModName _ = Nothing
-newtype ModuleStage = ModuleStage Int deriving (Eq, Ord)
+data ModuleStage = RunStage | CompileStage deriving (Eq, Ord)
+
+minStage :: ModuleStage
+minStage = RunStage
+maxStage :: ModuleStage
+maxStage = CompileStage
instance Outputable ModuleStage where
- ppr (ModuleStage p) = ppr p
+ ppr CompileStage = text "compile"
+ ppr RunStage = text "run"
zeroStage :: ModuleStage
-zeroStage = ModuleStage 1
+zeroStage = RunStage
todoStage :: HasCallStack => ModuleStage
todoStage -- = pprTrace "todoStage" callStackDoc
= zeroStage
-moduleStageToThLevel :: ModuleStage -> Int
-moduleStageToThLevel (ModuleStage m) = m
+--moduleStageToThLevel :: ModuleStage -> Int
+--moduleStageToThLevel (ModuleStage m) = m
decModuleStage, incModuleStage :: ModuleStage -> ModuleStage
-incModuleStage (ModuleStage m) = ModuleStage (m + 1)
-decModuleStage (ModuleStage m) = ModuleStage (m - 1)
+incModuleStage RunStage = RunStage
+incModuleStage CompileStage = RunStage
+
+decModuleStage RunStage = CompileStage
+decModuleStage CompileStage = RunStage
data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot
, mnkLevel :: !ModuleStage
@@ -199,7 +218,8 @@ instance Outputable ModNodeKeyWithUid where
-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
data ModuleGraph = ModuleGraph
{ mg_mss :: [ModuleGraphNode]
- , mg_trans_deps :: Map.Map NodeKey (Set.Set NodeKey)
+ , mg_trans_deps :: (Map.Map NodeKey (Set.Set NodeKey), NodeKey -> Maybe ModuleGraphNode)
+ , mg_trans_deps_zero :: TDZ
-- A cached transitive dependency calculation so that a lot of work is not
-- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)
}
@@ -211,7 +231,8 @@ 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 uid lvl ms -> ModuleNode deps uid lvl (f ms)
+ ModuleNode deps lvl ms -> ModuleNode deps lvl (f ms)
+ UnitNode uids st uid -> UnitNode uids st uid
}
unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph
@@ -220,14 +241,18 @@ unionMG a b =
in ModuleGraph {
mg_mss = new_mss
, mg_trans_deps = mkTransDeps new_mss
+ , mg_trans_deps_zero = mkTransDepsZero new_mss
}
-mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey)
+mgTransDeps :: ModuleGraph -> (Map.Map NodeKey (Set.Set NodeKey), NodeKey -> Maybe ModuleGraphNode)
mgTransDeps = mg_trans_deps
+mgTransDepsZero :: ModuleGraph -> TDZ
+mgTransDepsZero = mg_trans_deps_zero
+
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
@@ -239,14 +264,14 @@ 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
go _ = Nothing
emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] Map.empty
+emptyMG = ModuleGraph [] (Map.empty, const Nothing) Map.empty
isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ms =
@@ -257,22 +282,27 @@ isTemplateHaskellOrQQNonBoot ms =
isExplicitStageMS :: ModSummary -> Bool
isExplicitStageMS ms = xopt LangExt.StagedImports (ms_hspp_opts ms)
--- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is
--- not an element of the ModuleGraph.
-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)
+extendModGraph :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
+extendModGraph mg mgn =
+ let res =
+ ModuleGraph {
+ mg_mss = mgn : mg_mss mg
+ , mg_trans_deps = mkTransDeps (mg_mss res)
+ , mg_trans_deps_zero = mkTransDepsZero (mg_mss res)
+ }
+ in res
+
+-- This collapses to zero.
+mkTransDeps :: [ModuleGraphNode] -> (Map.Map NodeKey (Set.Set NodeKey), NodeKey -> Maybe ModuleGraphNode)
mkTransDeps mss =
- let (gg, _lookup_node) = moduleGraphNodes False mss
- in allReachable gg (mkNodeKey . node_payload)
+ let (gg, lookup_node) = moduleGraphNodes False CollapseToZero mss
+ in (allReachable gg (mkNodeKey . node_payload), fmap summaryNodeSummary . lookup_node)
-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
+type TDZ = Map.Map (Either (ModNodeKeyWithUid, ImportStage) UnitId) (Set.Set (Either (ModNodeKeyWithUid, ImportStage) UnitId))
+
+mkTransDepsZero :: [ModuleGraphNode] -> TDZ
+mkTransDepsZero mss =
+ let (gg, _lookup_node) = moduleGraphNodesZero mss
in allReachable gg node_payload
extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
@@ -280,14 +310,8 @@ extendMGInst mg uid depUnitId = mg
{ mg_mss = InstantiationNode uid depUnitId : mg_mss mg
}
-extendMGLink :: ModuleGraph -> UnitId -> [NodeKey] -> ModuleGraph
-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 uid lvl ms -> extendMG mg deps uid lvl ms
- LinkNode deps uid -> extendMGLink mg uid deps
+extendMG' = extendModGraph
mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph = foldr (flip extendMG') emptyMG
@@ -297,11 +321,12 @@ collapseModuleGraph = mkModuleGraph . collapseModuleGraphNodes . mgModSummaries'
-- Collapse information about levels and map everything to level 0
collapseModuleGraphNodes :: [ModuleGraphNode] -> [ModuleGraphNode]
-collapseModuleGraphNodes m = nub $ map go m
+collapseModuleGraphNodes m = nubOrd $ map go m
where
- 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 (ModuleNode deps _lvl ms) = ModuleNode (nubOrd $ map (bimap (const NormalStage) collapseNodeKey) deps) zeroStage ms
+ go (LinkNode deps uid) = LinkNode (nubOrd $ map collapseNodeKey deps) uid
go (InstantiationNode uid iuid) = InstantiationNode uid iuid
+ go (UnitNode uids st uid) = UnitNode uids st uid
collapseNodeKey :: NodeKey -> NodeKey
collapseNodeKey (NodeKey_Module (ModNodeKeyWithUid mn _lvl uid))
@@ -320,7 +345,8 @@ filterToposortToModules
filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
InstantiationNode _ _ -> Nothing
LinkNode{} -> Nothing
- ModuleNode _deps _uid _lvl node -> Just node
+ UnitNode {} -> Nothing
+ ModuleNode _deps _lvl node -> Just node
where
-- This higher order function is somewhat bogus,
-- as the definition of "strongly connected component"
@@ -334,6 +360,7 @@ filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
as -> Just $ CyclicSCC as
showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc
+showModMsg _ _ (UnitNode _ st uid) = ppr uid <+> text "at" <+> ppr st
showModMsg dflags _ (LinkNode {}) =
let staticLink = case ghcLink dflags of
LinkStaticLib -> True
@@ -345,7 +372,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 $
@@ -391,23 +418,31 @@ 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 _lvl _ms ->
map drop_hs_boot deps
+ UnitNode uids st _ -> map (NodeKey_ExternalUnit st) uids
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 (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) lvl uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) lvl uid))
- drop_hs_boot x = x
+ drop_hs_boot (i, (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) lvl uid))) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) lvl uid))
+ drop_hs_boot (_, x) = x
+
+
+data CollapseToZero = CollapseToZero | UseStages
-- | 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.
+
+-- The CollapseToZero parameter
+-- For example, traversals which find type class instances are ignorant to levels.
moduleGraphNodes :: Bool
+ -> CollapseToZero
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
-moduleGraphNodes drop_hs_boot_nodes summaries =
+moduleGraphNodes drop_hs_boot_nodes collapse_to_zero summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
-- Map from module to extra boot summary dependencies which need to be merged in
@@ -416,7 +451,7 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
where
go (s, key) =
case s of
- ModuleNode __deps _uid _lvl ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes
+ ModuleNode __deps _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)
@@ -430,7 +465,11 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
(fromMaybe [] extra
++ nodeDependencies drop_hs_boot_nodes s)
- numbered_summaries = zip summaries [1..]
+ collapsed_summaries = case collapse_to_zero of
+ CollapseToZero -> collapseModuleGraphNodes summaries
+ UseStages -> summaries
+
+ numbered_summaries = zip collapsed_summaries [1..]
lookup_node :: NodeKey -> Maybe SummaryNode
lookup_node key = Map.lookup key (unNodeMap node_map)
@@ -472,54 +511,33 @@ zeroSummaryNodeSummary = node_payload
-- 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]
+ [ModuleGraphNode]
-> (Graph ZeroSummaryNode, Either (ModNodeKeyWithUid, ImportStage) UnitId -> Maybe ZeroSummaryNode)
-moduleGraphNodesZero us summaries =
+moduleGraphNodesZero 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 :: (((ModuleGraphNode, ImportStage)), 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 :: (ModuleGraphNode, ImportStage) -> Maybe ZeroSummaryNode
+ normal_case (((ModuleNode nks lvl ms), s)) = Just $
+ DigraphNode (Left (msKey lvl ms, s)) key $ out_edge_keys $
+ mapMaybe (classifyDeps s) nks
+ normal_case ((UnitNode uids _lvl uid), _s) =
+ Just $ DigraphNode (Right uid) key (mapMaybe lookup_key $ map Right uids)
normal_case _ = Nothing
- only_module_deps ds = [ 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 {} -> go cache uxs
- Nothing -> case unitDepends <$> lookupUnitId us u of
- Just us -> go (go (Map.insert u us cache) us) uxs
- Nothing -> panic "bad"
+ classifyDeps s (il, (NodeKey_Module k)) | s == il = Just (Left k)
+ classifyDeps s (il, (NodeKey_ExternalUnit lvl u)) | s == il = Just (Right (lvl, u))
+ classifyDeps _ _ = Nothing
- unit_depends :: ModuleGraphNode -> [UnitId]
- unit_depends (ModuleNode _ uids _ _) = map snd $ filter ((== zeroStage) . fst) uids
- unit_depends _ = []
+ numbered_summaries :: [((ModuleGraphNode, ImportStage), Int)]
+ numbered_summaries = zip (([(s, l) | s <- summaries, l <- [SpliceStage, QuoteStage, NormalStage]])) [0..]
lookup_node :: Either (ModNodeKeyWithUid, ImportStage) UnitId -> Maybe ZeroSummaryNode
lookup_node key = Map.lookup key node_map
@@ -534,8 +552,8 @@ moduleGraphNodesZero us summaries =
, 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))
+ out_edge_keys :: [Either ModNodeKeyWithUid (ModuleStage, UnitId)] -> [Int]
+ out_edge_keys = mapMaybe lookup_key . map (bimap (, NormalStage) snd)
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- IsBoot; else False
@@ -545,8 +563,9 @@ newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
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
+ UnitNode _ st uid -> NodeKey_ExternalUnit st uid
msKey :: ModuleStage -> ModSummary -> ModNodeKeyWithUid
msKey l ms = ModNodeKeyWithUid (ms_mnwib ms) l (ms_unitid ms)
@@ -561,7 +580,7 @@ type ModNodeKey = ModuleNameWithIsBoot
moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleStage -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
moduleGraphModulesBelow mg uid lvl mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
where
- td_map = mgTransDeps mg
+ (td_map, _) = mgTransDeps mg
modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn lvl uid)) td_map
=====================================
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
=====================================
testsuite/tests/splice-imports/SI22.stderr
=====================================
@@ -0,0 +1,4 @@
+SI22.hs: error: [GHC-92213]
+ Module graph contains a cycle:
+ module ‘SI22’ (SI22.hs) imports itself
+
=====================================
testsuite/tests/splice-imports/SI23.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE ExplicitStageImports #-}
+{-# LANGUAGE TemplateHaskell #-}
+module SI23 where
+
+import splice SI23A
+import splice Language.Haskell.TH.Syntax
+import SI23A
+
+main = print $(lift B)
=====================================
testsuite/tests/splice-imports/SI23A.hs
=====================================
@@ -0,0 +1,5 @@
+module SI23A where
+
+import Language.Haskell.TH.Syntax
+
+data B = B deriving (Lift, Show)
=====================================
testsuite/tests/splice-imports/SI24.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitStageImports #-}
+module SI24 where
+
+-- Identifiers can be used in variables
+
+splice = quote
+
+quote = splice
=====================================
testsuite/tests/splice-imports/all.T
=====================================
@@ -27,4 +27,5 @@ test('SI20', extra_files(["SI19A.hs"]), multimod_compile_fail, ['SI20', '-v0'])
test('SI21', normal, multimod_compile_fail, ['SI21', '-v0'])
test('SI22', normal, multimod_compile_fail, ['SI22', '-v0'])
test('SI23', extra_files(["SI23A.hs"]), multimod_compile, ['SI23', '-v0'])
+test('SI24', normal, compile, [''])
=====================================
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/ce8950bc98b5bcde029664c503a55deeec3abe01...eaf0f1b0c0ad240e011e44941bf2190c47a3b866
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ce8950bc98b5bcde029664c503a55deeec3abe01...eaf0f1b0c0ad240e011e44941bf2190c47a3b866
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/20241115/b7ac7869/attachment-0001.html>
More information about the ghc-commits
mailing list