Patrick pushed to branch wip/T26118-remove-hptallfaminstances-usage-during-upsweep at Glasgow Haskell Compiler / GHC Commits: 8b3c8036 by soulomoon at 2025-06-13T04:10:16+08:00 reuse hugInstancesBelow to get hpt fam instances for checkFamInstConsistency - - - - - 3 changed files: - compiler/GHC/Driver/Env.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs Changes: ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -34,7 +34,6 @@ module GHC.Driver.Env , hugInstancesBelow , hugAnnsBelow , hugCompleteSigsBelow - , hugFamInstancesBelow -- * Legacy API , hscUpdateHPT @@ -231,17 +230,6 @@ hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn -hugFamInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (ModuleEnv FamInstEnv) -hugFamInstancesBelow = hugSomeThingsBelowUs' combine emptyModuleEnv True - where - hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv . (md_fam_insts . hm_details) - hmiModule = mi_module . hm_iface - combine :: HomeModInfo -> ModuleEnv FamInstEnv -> ModuleEnv FamInstEnv - combine md acc = do - let famInstEnv = hmiFamInstEnv md - mod = hmiModule md - in extendModuleEnvWith unionFamInstEnv acc mod famInstEnv - -- | Find all COMPLETE pragmas in modules that are in the transitive closure of the -- given module. hugCompleteSigsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO CompleteMatches @@ -249,7 +237,7 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn -- | Find instances visible from the given set of imports -hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)]) hugInstancesBelow hsc_env uid mnwib = do let mn = gwib_mod mnwib (insts, famInsts) <- @@ -259,7 +247,7 @@ hugInstancesBelow hsc_env uid mnwib = do -- Don't include instances for the current module in if moduleName (mi_module (hm_iface mod_info)) == mn then [] - else [(md_insts details, md_fam_insts details)]) + else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])]) True -- Include -hi-boot hsc_env uid @@ -269,19 +257,16 @@ hugInstancesBelow hsc_env uid mnwib = do -- | Get things from modules in the transitive closure of the given module. -- -- Note: Don't expose this function. This is a footgun if exposed! -hugSomeThingsBelowUs' :: (HomeModInfo -> a -> a) -> a -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO a -hugSomeThingsBelowUs' _ acc _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return acc +hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] -- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk -- These things are currently stored in the EPS for home packages. (See #25795 for -- progress in removing these kind of checks) -- See Note [Downsweep and the ModuleGraph] -hugSomeThingsBelowUs' combine acc include_hi_boot hsc_env uid mn +hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] +hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn = let hug = hsc_HUG hsc_env mg = hsc_mod_graph hsc_env - combine' Nothing acc = acc - combine' (Just hmi) acc = combine hmi acc in - foldr combine' acc <$> sequence [ things -- "Finding each non-hi-boot module below me" maybe could be cached (well, @@ -300,8 +285,8 @@ hugSomeThingsBelowUs' combine acc include_hi_boot hsc_env uid mn -- Look it up in the HUG , let things = lookupHug hug mod_uid mod >>= \case - Just info -> return $ Just info - Nothing -> pprTrace "WARNING in hugSomeThingsBelowUs" msg (pure Nothing) + Just info -> return $ extract info + Nothing -> pprTrace "WARNING in hugSomeThingsBelowUs" msg mempty msg = vcat [text "missing module" <+> ppr mod, text "When starting from" <+> ppr mn, text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn), @@ -309,14 +294,6 @@ hugSomeThingsBelowUs' combine acc include_hi_boot hsc_env uid mn -- This really shouldn't happen, but see #962 ] --- | Get things from modules in the transitive closure of the given module. --- --- Note: Don't expose this function. This is a footgun if exposed! -hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] -hugSomeThingsBelowUs f = hugSomeThingsBelowUs' combine [] - where - combine hmi acc = f hmi : acc - -- | Deal with gathering annotations in from all possible places -- and combining them into a single 'AnnEnv' prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -25,7 +25,6 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Iface.Load -import GHC.IO (unsafeInterleaveIO) import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence @@ -287,8 +286,8 @@ why we still do redundant checks. -- We don't need to check the current module, this is done in -- tcExtendLocalFamInstEnv. -- See Note [The type family instance consistency story]. -checkFamInstConsistency :: [Module] -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> TcM () -checkFamInstConsistency directlyImpMods hsc_env unitId mnwib +checkFamInstConsistency :: ModuleEnv FamInstEnv -> [Module] -> TcM () +checkFamInstConsistency hpt_fam_insts directlyImpMods = do { (eps, hug) <- getEpsAndHug ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as @@ -318,7 +317,6 @@ checkFamInstConsistency directlyImpMods hsc_env unitId mnwib -- See Note [Order of type family consistency checks] } - ; hpt_fam_insts <- liftIO $ unsafeInterleaveIO $ hugFamInstancesBelow hsc_env unitId mnwib ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods ; traceTc "init_consistent_set" (ppr debug_consistent_set) ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set)) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -120,7 +120,7 @@ import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.TyCo.Tidy( tidyTopType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst - , famInstEnvElts, extendFamInstEnvList, normaliseType ) + , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv ) import GHC.Parser.Header ( mkPrelImports ) @@ -467,8 +467,8 @@ tcRnImports hsc_env import_decls = do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls -- Get the default declarations for the classes imported by this module -- and group them by class. - ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)) - <$> tcGetClsDefaults (M.keys $ imp_mods imports) + ; tc_defaults <- NE.groupBy ((==) `on` cd_class) . (concatMap defaultList) + <$> tcGetClsDefaults (M.keys $ imp_mods imports) ; this_mod <- getModule ; gbl_env <- getGblEnv ; let unitId = homeUnitId $ hsc_home_unit hsc_env @@ -480,8 +480,10 @@ 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_insts, home_fam_insts) <- liftIO $ + ; (home_insts, home_mod_fam_inst_env) <- liftIO $ hugInstancesBelow hsc_env unitId mnwib + ; let home_fam_inst_env = foldl' unionFamInstEnv emptyFamInstEnv $ snd <$> home_mod_fam_inst_env + ; let hpt_fam_insts = mkModuleEnv home_mod_fam_inst_env -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad @@ -507,8 +509,7 @@ tcRnImports hsc_env import_decls tcg_rn_imports = rn_imports, tcg_default = foldMap subsume tc_defaults, tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts + tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env }) $ do { ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) @@ -538,7 +539,7 @@ tcRnImports hsc_env import_decls $ imports } ; logger <- getLogger ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) - $ checkFamInstConsistency dir_imp_mods hsc_env unitId mnwib + $ checkFamInstConsistency hpt_fam_insts dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty ; gbl_env <- getGblEnv View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b3c8036e60263902061622ddfeb7fe5... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b3c8036e60263902061622ddfeb7fe5... You're receiving this email because of your account on gitlab.haskell.org.