Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0975d2b6 by sheaf at 2025-09-08T03:38:54-04:00 Revert "Remove hptAllFamInstances usage during upsweep" This reverts commit 3bf6720eff5e86e673568e756161e6d6150eb440. - - - - - 0cf34176 by soulomoon at 2025-09-08T03:38:54-04:00 Family consistency checks: add test for #26154 This commit adds the test T26154, to make sure that GHC doesn't crash when performing type family consistency checks. This test case was extracted from Agda. Fixes #26154 - - - - - 11 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 - + testsuite/tests/typecheck/should_compile/T26154.hs - + testsuite/tests/typecheck/should_compile/T26154_A.hs - + testsuite/tests/typecheck/should_compile/T26154_B.hs - + testsuite/tests/typecheck/should_compile/T26154_B.hs-boot - + testsuite/tests/typecheck/should_compile/T26154_Other.hs - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -246,7 +246,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, [(Module, FamInstEnv)]) +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) hugInstancesBelow hsc_env uid mnwib = do let mn = gwib_mod mnwib (insts, famInsts) <- @@ -256,7 +256,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, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])]) + else [(md_insts details, md_fam_insts details)]) True -- Include -hi-boot hsc_env uid ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -286,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 :: ModuleEnv FamInstEnv -> [Module] -> TcM () -checkFamInstConsistency hpt_fam_insts directlyImpMods +checkFamInstConsistency :: [Module] -> TcM () +checkFamInstConsistency directlyImpMods = do { (eps, hug) <- getEpsAndHug ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as @@ -317,6 +317,7 @@ checkFamInstConsistency hpt_fam_insts directlyImpMods -- See Note [Order of type family consistency checks] } + ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug ; 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 ===================================== @@ -119,7 +119,7 @@ import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.TyCo.Tidy( tidyTopType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst - , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv ) + , famInstEnvElts, extendFamInstEnvList, normaliseType ) import GHC.Parser.Header ( mkPrelImports ) @@ -464,8 +464,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 @@ -477,10 +477,8 @@ 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_mod_fam_inst_env) <- liftIO $ + ; (home_insts, home_fam_insts) <- 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 @@ -506,7 +504,8 @@ 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 = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts }) $ do { ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) @@ -536,7 +535,7 @@ tcRnImports hsc_env import_decls $ imports } ; logger <- getLogger ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) - $ checkFamInstConsistency hpt_fam_insts dir_imp_mods + $ checkFamInstConsistency dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty ; gbl_env <- getGblEnv ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -43,6 +43,7 @@ module GHC.Unit.Home.Graph -- * Very important queries , allInstances + , allFamInstances , allAnns , allCompleteSigs @@ -109,6 +110,10 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b')) (hptAllInstances (homeUnitEnv_hpt hue)) +allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv) +allFamInstances hug = foldr go (pure emptyModuleEnv) hug where + go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue)) + allAnns :: HomeUnitGraph -> IO AnnEnv allAnns hug = foldr go (pure emptyAnnEnv) hug where go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue)) ===================================== compiler/GHC/Unit/Home/PackageTable.hs ===================================== @@ -41,6 +41,7 @@ module GHC.Unit.Home.PackageTable -- * Queries about home modules , hptCompleteSigs , hptAllInstances + , hptAllFamInstances , hptAllAnnotations -- ** More Traversal-based queries @@ -207,6 +208,14 @@ hptAllInstances hpt = do let (insts, famInsts) = unzip hits return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) +-- | Find all the family instance declarations from the HPT +hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv) +hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)]) + where + hmiModule = mi_module . hm_iface + hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv + . md_fam_insts . hm_details + -- | All annotations from the HPT hptAllAnnotations :: HomePackageTable -> IO AnnEnv hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details) ===================================== testsuite/tests/typecheck/should_compile/T26154.hs ===================================== @@ -0,0 +1,5 @@ + +module T26154 where + +import {-# SOURCE #-} T26154_B +import T26154_Other ===================================== testsuite/tests/typecheck/should_compile/T26154_A.hs ===================================== @@ -0,0 +1,9 @@ + +{-# LANGUAGE TypeFamilies #-} + +module T26154_A where + +import {-# SOURCE #-} T26154_B + +type family F a b +type instance F a b = b ===================================== testsuite/tests/typecheck/should_compile/T26154_B.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} + +module T26154_B where + +import T26154_A + +type family FAA a b + +type instance FAA a b = b \ No newline at end of file ===================================== testsuite/tests/typecheck/should_compile/T26154_B.hs-boot ===================================== @@ -0,0 +1,3 @@ +{-# LANGUAGE TypeFamilies #-} + +module T26154_B where ===================================== testsuite/tests/typecheck/should_compile/T26154_Other.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T26154_Other where + +type family OtherF a b + +type instance OtherF a b = b \ No newline at end of file ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -947,6 +947,7 @@ test('T25992', normal, compile, ['']) test('T14010', normal, compile, ['']) test('T26256a', normal, compile, ['']) test('T25992a', normal, compile, ['']) +test('T26154', [extra_files(['T26154_A.hs', 'T26154_B.hs', 'T26154_B.hs-boot', 'T26154_Other.hs'])], multimod_compile, ['T26154', '-v0']) test('T26346', normal, compile, ['']) test('T26358', expect_broken(26358), compile, ['']) test('T26345', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/624afa4a65caa8ec23f85e70574dfb6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/624afa4a65caa8ec23f85e70574dfb6... You're receiving this email because of your account on gitlab.haskell.org.