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>

1 files changed, 8 insertions, 25 deletions

diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index a4dbdcb75d..a18899ec09 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -11,8 +11,8 @@ module GHC.Core.Unify (
         tcMatchTyX_BM, ruleMatchTyKiX,
 
         -- * Rough matching
-        RoughMatchTc(..), roughMatchTcs, instanceCantMatch,
-        typesCantMatch, isRoughOtherTc,
+        RoughMatchTc(..), roughMatchTcs, roughMatchTcsLookup, instanceCantMatch,
+        typesCantMatch, isRoughWildcard,
 
         -- Side-effect free unification
         tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,
@@ -39,6 +39,7 @@ import GHC.Core.TyCon
 import GHC.Core.TyCo.Rep
 import GHC.Core.TyCo.FVs   ( tyCoVarsOfCoList, tyCoFVsOfTypes )
 import GHC.Core.TyCo.Subst ( mkTvSubst )
+import GHC.Core.RoughMap
 import GHC.Core.Map.Type
 import GHC.Utils.FV( FV, fvVarSet, fvVarList )
 import GHC.Utils.Misc
@@ -49,11 +50,9 @@ import GHC.Types.Unique.FM
 import GHC.Types.Unique.Set
 import {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType )
 import GHC.Exts( oneShot )
-import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Data.FastString
 
-import Data.Data ( Data )
 import Data.List ( mapAccumL )
 import Control.Monad
 import qualified Data.Semigroup as S
@@ -291,27 +290,11 @@ But it is never
              albeit perhaps only after 'a' is instantiated.
 -}
 
-data RoughMatchTc
-  = KnownTc Name   -- INVARIANT: Name refers to a TyCon tc that responds
-                   -- true to `isGenerativeTyCon tc Nominal`. See
-                   -- Note [Rough matching in class and family instances]
-  | OtherTc        -- e.g. type variable at the head
-  deriving( Data )
-
-isRoughOtherTc :: RoughMatchTc -> Bool
-isRoughOtherTc OtherTc      = True
-isRoughOtherTc (KnownTc {}) = False
-
 roughMatchTcs :: [Type] -> [RoughMatchTc]
-roughMatchTcs tys = map rough tys
-  where
-    rough ty
-      | Just (ty', _) <- splitCastTy_maybe ty   = rough ty'
-      | Just (tc,_)   <- splitTyConApp_maybe ty
-      , not (isTypeFamilyTyCon tc)              = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) $
-                                                  KnownTc (tyConName tc)
-        -- See Note [Rough matching in class and family instances]
-      | otherwise                               = OtherTc
+roughMatchTcs tys = map typeToRoughMatchTc tys
+
+roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc]
+roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys
 
 instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool
 -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot
@@ -321,7 +304,7 @@ instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch
 instanceCantMatch _         _         =  False  -- Safe
 
 itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool
-itemCantMatch (KnownTc t) (KnownTc a) = t /= a
+itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a
 itemCantMatch _           _           = False