compiler: Introduce and use RoughMap for instance environmentswip/roughmap-mp

Here we introduce a new data structure, RoughMap, inspired by the
previous `RoughTc` matching mechanism for checking instance matches.
This allows [Fam]InstEnv to be implemented as a trie indexed by these
RoughTc signatures, reducing the complexity of instance lookup and
FamInstEnv merging (done during the family instance conflict test)
from O(n) to O(log n).

The critical performance improvement currently realised by this patch is
in instance matching. In particular the RoughMap mechanism allows us to
discount many potential instances which will never match for constraints
involving type variables (see Note [Matching a RoughMap]). In realistic
code bases matchInstEnv was accounting for 50% of typechecker time due
to redundant work checking instances when simplifying instance contexts
when deriving instances. With this patch the cost is significantly
reduced.

The larger constants in InstEnv creation do mean that a few small
tests regress in allocations slightly. However, the runtime of T19703 is
reduced by a factor of 4. Moreover, the compilation time of the Cabal
library is slightly improved.

A couple of test cases are included which demonstrate significant
improvements in compile time with this patch.

This unfortunately does not fix the testcase provided in #19703 but does
fix #20933

-------------------------
Metric Decrease:
    T12425
Metric Increase:
    T13719
    T9872a
    T9872d
    hard_hole_fits
-------------------------

Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com>

7 files changed, 33 insertions, 34 deletions

diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 70f5d0ddd7..82aa8fcc6a 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1897,7 +1897,7 @@ mkDictErr ctxt cts
     is_no_inst (ct, (matches, unifiers, _))
       =  no_givens
       && null matches
-      && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
+      && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
 
     lookup_cls_inst inst_envs ct
       = (ct, lookupInstEnv True inst_envs clas tys)
@@ -1988,13 +1988,13 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
 
     cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcReportMsg
     cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions
-      = CannotResolveInstance ct unifiers candidate_insts imp_errs field_suggestions binds
+      = CannotResolveInstance ct (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds
 
     -- Overlap errors.
     overlap_msg, safe_haskell_msg :: TcReportMsg
     -- Normal overlap error
     overlap_msg
-      = assert (not (null matches)) $ OverlappingInstances ct ispecs unifiers
+      = assert (not (null matches)) $ OverlappingInstances ct ispecs (getPotentialUnifiers unifiers)
 
     -- Overlap error because of Safe Haskell (first
     -- match should be the most specific match)
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 747b3a7d98..7264f2232a 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1715,7 +1715,7 @@ reifyInstances' th_nm th_tys
                -> do { inst_envs <- tcGetInstEnvs
                      ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
                      ; traceTc "reifyInstances'1" (ppr matches)
-                     ; return $ Left (cls, map fst matches ++ unifies) }
+                     ; return $ Left (cls, map fst matches ++ getPotentialUnifiers unifies) }
                | isOpenFamilyTyCon tc
                -> do { inst_envs <- tcGetFamInstEnvs
                      ; let matches = lookupFamInstEnv inst_envs tc tys
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 8063ce7720..df7046c4fd 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -172,12 +172,12 @@ matchInstEnv dflags short_cut_solver clas tys
         ; case (matches, unify, safeHaskFail) of
 
             -- Nothing matches
-            ([], [], _)
+            ([], NoUnifiers, _)
                 -> do { traceTc "matchClass not matching" (ppr pred)
                       ; return NoInstance }
 
             -- A single match (& no safe haskell failure)
-            ([(ispec, inst_tys)], [], False)
+            ([(ispec, inst_tys)], NoUnifiers, False)
                 | short_cut_solver      -- Called from the short-cut solver
                 , isOverlappable ispec
                 -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT
diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs
index 6ce522385b..8b76c9f4cd 100644
--- a/compiler/GHC/Tc/Instance/Family.hs
+++ b/compiler/GHC/Tc/Instance/Family.hs
@@ -700,7 +700,7 @@ checkForConflicts :: FamInstEnvs -> FamInst -> TcM ()
 checkForConflicts inst_envs fam_inst
   = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
        ; traceTc "checkForConflicts" $
-         vcat [ ppr (map fim_instance conflicts)
+         vcat [ ppr conflicts
               , ppr fam_inst
               -- , ppr inst_envs
          ]
@@ -991,20 +991,18 @@ buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage)
 buildInjectivityError mkErr fam_tc branches
   = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches )
 
-reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()
+reportConflictInstErr :: FamInst -> [FamInst] -> TcRn ()
 reportConflictInstErr _ []
   = return ()  -- No conflicts
-reportConflictInstErr fam_inst (match1 : _)
-  | FamInstMatch { fim_instance = conf_inst } <- match1
-  , let sorted  = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst])
-        fi1     = NE.head sorted
-        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
-  = setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted
- where
-   getSpan = getSrcSpan . famInstAxiom
+reportConflictInstErr fam_inst (conf_inst : _) =
    -- The sortBy just arranges that instances are displayed in order
    -- of source location, which reduced wobbling in error messages,
    -- and is better for users
+  let   sorted  = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst])
+        fi1     = NE.head sorted
+        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
+        getSpan = getSrcSpan . famInstAxiom
+  in setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted
 
 tcGetFamInstEnvs :: TcM FamInstEnvs
 -- Gets both the external-package inst-env
diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs
index 4b45f2fa38..cfbebcd368 100644
--- a/compiler/GHC/Tc/Instance/FunDeps.hs
+++ b/compiler/GHC/Tc/Instance/FunDeps.hs
@@ -227,11 +227,12 @@ improveFromInstEnv inst_env mk_loc cls tys
   where
     (cls_tvs, cls_fds) = classTvsFds cls
     instances          = classInstances inst_env cls
-    rough_tcs          = roughMatchTcs tys
+    rough_tcs          = RM_KnownTc (className cls) : roughMatchTcs tys
     pred               = mkClassPred cls tys
 
 
 
+
 improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class
              -> ClsInst                    -- An instance template
              -> [Type] -> [RoughMatchTc]   -- Arguments of this (C tys) predicate
@@ -673,8 +674,9 @@ trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc]
 -- Hence, we Nothing-ise the tb and tc types right here
 --
 -- Result list is same length as input list, just with more Nothings
-trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs
-  = zipWith select clas_tvs mb_tcs
+trimRoughMatchTcs _clas_tvs _ [] = panic "trimRoughMatchTcs: nullary [RoughMatchTc]"
+trimRoughMatchTcs clas_tvs (ltvs, _) (cls:mb_tcs)
+  = cls : zipWith select clas_tvs mb_tcs
   where
     select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc
-                         | otherwise           = OtherTc
+                         | otherwise           = RM_WildCard
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 505f0dd627..c8f65e2453 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -401,7 +401,7 @@ tcRnImports hsc_env import_decls
               tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
               tcg_rn_imports   = rn_imports,
-              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
+              tcg_inst_env     = tcg_inst_env gbl `unionInstEnv` home_insts,
               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
                                                       home_fam_insts,
               tcg_hpc          = hpc_info
@@ -1721,7 +1721,7 @@ tcMissingParentClassWarn warnFlag isName shouldName
            -- "<location>: Warning: <type> is an instance of <is> but not
            -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
            ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
-                 warnMsg (KnownTc name:_) =
+                 warnMsg (RM_KnownTc name:_) =
                       addDiagnosticAt instLoc $
                         TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $
                            hsep [ (quotes . ppr . nameOccName) name
@@ -1734,7 +1734,7 @@ tcMissingParentClassWarn warnFlag isName shouldName
                            hsep [ text "This will become an error in"
                                 , text "a future release." ]
                  warnMsg _ = pure ()
-           ; when (null shouldInsts && null instanceMatches) $
+           ; when (nullUnifiers shouldInsts && null instanceMatches) $
                   warnMsg (is_tcs isInst)
            }
 
@@ -2041,7 +2041,7 @@ runTcInteractive hsc_env thing_inside
     withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $
     do { traceTc "setInteractiveContext" $
             vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
-                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
+                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts))
                  , text "icReaderEnv (LocalDef)" <+>
                       vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt)
                                                  , let local_gres = filter isLocalGRE gres
@@ -2064,13 +2064,12 @@ runTcInteractive hsc_env thing_inside
                where
                  gbl_env' = gbl_env { tcg_rdr_env      = icReaderEnv icxt
                                     , tcg_type_env     = type_env
-                                    , tcg_inst_env     = extendInstEnvList
-                                                          (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
-                                                          home_insts
+
+                                    , tcg_inst_env     = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts
                                     , tcg_fam_inst_env = extendFamInstEnvList
-                                                          (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
-                                                                                ic_finsts)
-                                                          home_fam_insts
+                                               (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
+                                                                     ic_finsts)
+                                               home_fam_insts
                                     , tcg_field_env    = mkNameEnv con_fields
                                          -- setting tcg_field_env is necessary
                                          -- to make RecordWildCards work (test: ghci049)
@@ -2103,7 +2102,7 @@ runTcInteractive hsc_env thing_inside
       = Right thing
 
     type_env1 = mkTypeEnvWithImplicits top_ty_things
-    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
+    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts))
                 -- Putting the dfuns in the type_env
                 -- is just to keep Core Lint happy
 
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 20b81f8b3c..d553ec4fad 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -146,7 +146,7 @@ checkHsigIface tcg_env gr sig_iface
                         tcg_fam_inst_env = emptyFamInstEnv,
                         tcg_insts = [],
                         tcg_fam_insts = [] } $ do
-    mapM_ check_inst sig_insts
+    mapM_ check_inst (instEnvElts sig_insts)
     failIfErrsM
   where
     -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig
@@ -156,7 +156,7 @@ checkHsigIface tcg_env gr sig_iface
     sig_type_occ_env = mkOccEnv
                      . map (\t -> (nameOccName (getName t), t))
                      $ nonDetNameEnvElts sig_type_env
-    dfun_names = map getName sig_insts
+    dfun_names = map getName (instEnvElts sig_insts)
     check_export name
       -- Skip instances, we'll check them later
       -- TODO: Actually this should never happen, because DFuns are
@@ -865,7 +865,7 @@ mergeSignatures
                 = (inst:insts, extendInstEnv inst_env inst)
             (insts, inst_env) = foldl' merge_inst
                                     (tcg_insts tcg_env, tcg_inst_env tcg_env)
-                                    (md_insts details)
+                                    (instEnvElts $ md_insts details)
             -- This is a HACK to prevent calculateAvails from including imp_mod
             -- in the listing.  We don't want it because a module is NOT
             -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214