Revert "Remove hptAllFamInstances usage during upsweep"

This reverts commit 3bf6720.

Author: sheaf

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)