Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
-
3bf6720e
by soulomoon at 2025-06-23T13:55:52-04:00
5 changed files:
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Home/PackageTable.hs
Changes:
... | ... | @@ -245,7 +245,7 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> |
245 | 245 | hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn
|
246 | 246 | |
247 | 247 | -- | Find instances visible from the given set of imports
|
248 | -hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])
|
|
248 | +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)])
|
|
249 | 249 | hugInstancesBelow hsc_env uid mnwib = do
|
250 | 250 | let mn = gwib_mod mnwib
|
251 | 251 | (insts, famInsts) <-
|
... | ... | @@ -255,7 +255,7 @@ hugInstancesBelow hsc_env uid mnwib = do |
255 | 255 | -- Don't include instances for the current module
|
256 | 256 | in if moduleName (mi_module (hm_iface mod_info)) == mn
|
257 | 257 | then []
|
258 | - else [(md_insts details, md_fam_insts details)])
|
|
258 | + else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])])
|
|
259 | 259 | True -- Include -hi-boot
|
260 | 260 | hsc_env
|
261 | 261 | uid
|
... | ... | @@ -286,8 +286,8 @@ why we still do redundant checks. |
286 | 286 | -- We don't need to check the current module, this is done in
|
287 | 287 | -- tcExtendLocalFamInstEnv.
|
288 | 288 | -- See Note [The type family instance consistency story].
|
289 | -checkFamInstConsistency :: [Module] -> TcM ()
|
|
290 | -checkFamInstConsistency directlyImpMods
|
|
289 | +checkFamInstConsistency :: ModuleEnv FamInstEnv -> [Module] -> TcM ()
|
|
290 | +checkFamInstConsistency hpt_fam_insts directlyImpMods
|
|
291 | 291 | = do { (eps, hug) <- getEpsAndHug
|
292 | 292 | ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)
|
293 | 293 | ; let { -- Fetch the iface of a given module. Must succeed as
|
... | ... | @@ -317,7 +317,6 @@ checkFamInstConsistency directlyImpMods |
317 | 317 | -- See Note [Order of type family consistency checks]
|
318 | 318 | }
|
319 | 319 | |
320 | - ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug
|
|
321 | 320 | ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods
|
322 | 321 | ; traceTc "init_consistent_set" (ppr debug_consistent_set)
|
323 | 322 | ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set))
|
... | ... | @@ -120,7 +120,7 @@ import GHC.Core.TyCo.Ppr( debugPprType ) |
120 | 120 | import GHC.Core.TyCo.Tidy( tidyTopType )
|
121 | 121 | import GHC.Core.FamInstEnv
|
122 | 122 | ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst
|
123 | - , famInstEnvElts, extendFamInstEnvList, normaliseType )
|
|
123 | + , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv )
|
|
124 | 124 | |
125 | 125 | import GHC.Parser.Header ( mkPrelImports )
|
126 | 126 | |
... | ... | @@ -467,8 +467,8 @@ tcRnImports hsc_env import_decls |
467 | 467 | = do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls
|
468 | 468 | -- Get the default declarations for the classes imported by this module
|
469 | 469 | -- and group them by class.
|
470 | - ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList))
|
|
471 | - <$> tcGetClsDefaults (M.keys $ imp_mods imports)
|
|
470 | + ; tc_defaults <- NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)
|
|
471 | + <$> tcGetClsDefaults (M.keys $ imp_mods imports)
|
|
472 | 472 | ; this_mod <- getModule
|
473 | 473 | ; gbl_env <- getGblEnv
|
474 | 474 | ; let unitId = homeUnitId $ hsc_home_unit hsc_env
|
... | ... | @@ -480,8 +480,10 @@ tcRnImports hsc_env import_decls |
480 | 480 | -- filtering also ensures that we don't see instances from
|
481 | 481 | -- modules batch (@--make@) compiled before this one, but
|
482 | 482 | -- which are not below this one.
|
483 | - ; (home_insts, home_fam_insts) <- liftIO $
|
|
483 | + ; (home_insts, home_mod_fam_inst_env) <- liftIO $
|
|
484 | 484 | hugInstancesBelow hsc_env unitId mnwib
|
485 | + ; let home_fam_inst_env = foldl' unionFamInstEnv emptyFamInstEnv $ snd <$> home_mod_fam_inst_env
|
|
486 | + ; let hpt_fam_insts = mkModuleEnv home_mod_fam_inst_env
|
|
485 | 487 | |
486 | 488 | -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations
|
487 | 489 | -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad
|
... | ... | @@ -507,8 +509,7 @@ tcRnImports hsc_env import_decls |
507 | 509 | tcg_rn_imports = rn_imports,
|
508 | 510 | tcg_default = foldMap subsume tc_defaults,
|
509 | 511 | tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts,
|
510 | - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
|
|
511 | - home_fam_insts
|
|
512 | + tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env
|
|
512 | 513 | }) $ do {
|
513 | 514 | |
514 | 515 | ; traceRn "rn1" (ppr (imp_direct_dep_mods imports))
|
... | ... | @@ -538,7 +539,7 @@ tcRnImports hsc_env import_decls |
538 | 539 | $ imports }
|
539 | 540 | ; logger <- getLogger
|
540 | 541 | ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ())
|
541 | - $ checkFamInstConsistency dir_imp_mods
|
|
542 | + $ checkFamInstConsistency hpt_fam_insts dir_imp_mods
|
|
542 | 543 | ; traceRn "rn1: } checking family instance consistency" empty
|
543 | 544 | |
544 | 545 | ; gbl_env <- getGblEnv
|
... | ... | @@ -43,7 +43,6 @@ module GHC.Unit.Home.Graph |
43 | 43 | |
44 | 44 | -- * Very important queries
|
45 | 45 | , allInstances
|
46 | - , allFamInstances
|
|
47 | 46 | , allAnns
|
48 | 47 | , allCompleteSigs
|
49 | 48 | |
... | ... | @@ -110,10 +109,6 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where |
110 | 109 | go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b'))
|
111 | 110 | (hptAllInstances (homeUnitEnv_hpt hue))
|
112 | 111 | |
113 | -allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv)
|
|
114 | -allFamInstances hug = foldr go (pure emptyModuleEnv) hug where
|
|
115 | - go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue))
|
|
116 | - |
|
117 | 112 | allAnns :: HomeUnitGraph -> IO AnnEnv
|
118 | 113 | allAnns hug = foldr go (pure emptyAnnEnv) hug where
|
119 | 114 | go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue))
|
... | ... | @@ -41,7 +41,6 @@ module GHC.Unit.Home.PackageTable |
41 | 41 | -- * Queries about home modules
|
42 | 42 | , hptCompleteSigs
|
43 | 43 | , hptAllInstances
|
44 | - , hptAllFamInstances
|
|
45 | 44 | , hptAllAnnotations
|
46 | 45 | |
47 | 46 | -- ** More Traversal-based queries
|
... | ... | @@ -208,14 +207,6 @@ hptAllInstances hpt = do |
208 | 207 | let (insts, famInsts) = unzip hits
|
209 | 208 | return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)
|
210 | 209 | |
211 | --- | Find all the family instance declarations from the HPT
|
|
212 | -hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv)
|
|
213 | -hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)])
|
|
214 | - where
|
|
215 | - hmiModule = mi_module . hm_iface
|
|
216 | - hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
|
|
217 | - . md_fam_insts . hm_details
|
|
218 | - |
|
219 | 210 | -- | All annotations from the HPT
|
220 | 211 | hptAllAnnotations :: HomePackageTable -> IO AnnEnv
|
221 | 212 | hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details)
|