[Git][ghc/ghc][wip/splice-imports-2024] 2 commits: fixes
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Nov 6 10:14:32 UTC 2024
Matthew Pickering pushed to branch wip/splice-imports-2024 at Glasgow Haskell Compiler / GHC
Commits:
7f295b31 by Matthew Pickering at 2024-11-06T10:04:28+00:00
fixes
- - - - -
33a7564e by Matthew Pickering at 2024-11-06T10:14:18+00:00
test output
- - - - -
5 changed files:
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Unit/Module/Graph.hs
- docs/users_guide/exts/template_haskell.rst
- testsuite/tests/th/T16976z.stderr
Changes:
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1673,7 +1673,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
(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 (maybeToList zero ++ next) (M.insert k (ModuleNode final_deps uids lvl ms) done'', summarised'')
+ loopSummaries (maybeToList zero ++ next) (M.insert k (ModuleNode final_deps (ordNub uids) lvl ms) done'', summarised'')
where
k = NodeKey_Module (msKey lvl ms)
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -214,10 +214,11 @@ import GHC.Data.Graph.Directed
#endif
import qualified Data.Set as Set
-import qualified Data.Map as Map
import GHC.Unit.Module.Graph
import Data.Bifunctor (bimap)
+import GHC.Data.Graph.Directed
+import GHC.Data.Maybe
{- *********************************************************************
* *
@@ -1457,8 +1458,11 @@ checkWellStagedInstanceWhat what
= do
cur_mod <- extractModule <$> getGblEnv
hsc_env <- getTopEnv
- let tg = mkTransDepsZero (hsc_units hsc_env) (mgModSummaries' (hsc_mod_graph hsc_env))
- 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 (mg, lookup_node) = moduleGraphNodesZero (hsc_units hsc_env) (mgModSummaries' $ 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)])
+-- 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
quote_lvl = lkup QuoteStage
@@ -1467,7 +1471,6 @@ checkWellStagedInstanceWhat what
instance_key = if moduleUnitId name_module `Set.member` hsc_all_home_unit_ids hsc_env
then Left name_module
else Right (moduleUnitId name_module)
-
let lvls = [ 0 | instance_key `Set.member` splice_lvl]
++ [ 1 | instance_key `Set.member` normal_lvl ]
++ [ 2 | instance_key `Set.member` quote_lvl ]
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -122,7 +122,7 @@ moduleGraphNodeUnitId mgn =
instance Outputable ModuleGraphNode where
ppr = \case
InstantiationNode _ iuid -> ppr iuid
- ModuleNode nks _ lvl ms -> ppr (msKey lvl ms) <+> ppr nks
+ ModuleNode nks uids lvl ms -> ppr (msKey lvl ms) <+> ppr nks <+> ppr uids
LinkNode uid _ -> text "LN:" <+> ppr uid
instance Eq ModuleGraphNode where
@@ -475,7 +475,7 @@ moduleGraphNodesZero ::
UnitState
-> [ModuleGraphNode]
-> (Graph ZeroSummaryNode, Either (ModNodeKeyWithUid, ImportStage) UnitId -> Maybe ZeroSummaryNode)
-moduleGraphNodesZero us summaries = pprTrace "mg_zero" (ppr summaries)
+moduleGraphNodesZero us summaries =
(graphFromEdgedVerticesUniq nodes, lookup_node)
where
-- Map from module to extra boot summary dependencies which need to be merged in
@@ -494,7 +494,7 @@ moduleGraphNodesZero us summaries = pprTrace "mg_zero" (ppr summaries)
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 ]
+ only_module_deps ds = [ k | NodeKey_Module k <- ds ]
jimmy_lvl l s = case s of
NormalStage -> l
@@ -511,7 +511,7 @@ moduleGraphNodesZero us summaries = pprTrace "mg_zero" (ppr summaries)
go cache [] = cache
go cache (u:uxs) =
case Map.lookup u cache of
- Just {} -> cache
+ 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"
=====================================
docs/users_guide/exts/template_haskell.rst
=====================================
@@ -469,6 +469,27 @@ splices and quotations are supported.)
was not written by the user. If you want to have warnings for splices
anyway, pass :ghc-flag:`-fenable-th-splice-warnings`.
+.. extension:: ExplicitStageImports
+ :shortdesc: TODO
+
+ :since: 8.0.1
+
+ Enable Template Haskell's quotation syntax.
+
+.. extension:: PathCSP
+ :shortdesc: TODO
+
+ :since: 8.0.1
+
+ Enable Template Haskell's quotation syntax.
+
+.. extension:: LiftCSP
+ :shortdesc: TODO
+
+ :since: 8.0.1
+
+ TODO
+
.. _th-usage:
Using Template Haskell
=====================================
testsuite/tests/th/T16976z.stderr
=====================================
@@ -1,5 +1,5 @@
-
-T16976z.hs:7:20: error: [GHC-57695]
- • Stage error: the non-top-level quoted name 'str
- must be used at the same stage at which it is bound.
+T16976z.hs:7:20: error: [GHC-28914]
+ • Stage error: ‘str’ is bound at stage {0} but used at stage 1
+ Hint: quoting [| str |] or an enclosing expression would allow the quotation to be used in an earlier stage
• In the Template Haskell quotation 'str
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b272697dbaae57edd7c770d39bc5325dbb7a04ba...33a7564e4c95c47f02ceac245d5da76b93be9899
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b272697dbaae57edd7c770d39bc5325dbb7a04ba...33a7564e4c95c47f02ceac245d5da76b93be9899
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/20241106/3501dcf5/attachment-0001.html>
More information about the ghc-commits
mailing list