Give Uniq[D]FM a phantom type for its key.

This fixes #17667 and should help to avoid such issues going forward.

The changes are mostly mechanical in nature. With two notable
exceptions.

* The register allocator.

  The register allocator references registers by distinct uniques.
  However they come from the types of VirtualReg, Reg or Unique in
  various places. As a result we sometimes cast the key type of the
  map and use functions which operate on the now typed map but take
  a raw Unique as actual key. The logic itself has not changed it
  just becomes obvious where we do so now.

* <Type>Env Modules.

As an example a ClassEnv is currently queried using the types `Class`,
`Name`, and `TyCon`. This is safe since for a distinct class value all
these expressions give the same unique.

    getUnique cls
    getUnique (classTyCon cls)
    getUnique (className cls)
    getUnique (tcName $ classTyCon cls)

This is for the most part contained within the modules defining the
interface. However it requires us to play dirty when we are given a
`Name` to lookup in a `UniqFM Class a` map. But again the logic did
not change and it's for the most part hidden behind the Env Module.

Some of these cases could be avoided by refactoring but this is left
for future work.

We also bump the haddock submodule as it uses UniqFM.

4 files changed, 15 insertions, 7 deletions

diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 0cd715634a..f803939da6 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -86,7 +86,7 @@ import GHC.Types.Name.Env
 import GHC.Driver.Session
 import GHC.Utils.Error
 import GHC.Data.FastString
-import GHC.Types.Unique.FM ( lookupWithDefaultUFM )
+import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly )
 import GHC.Types.Literal ( mkLitString )
 import GHC.Types.CostCentre.State
 
@@ -533,7 +533,10 @@ dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
 dsGetCompleteMatches tc = do
   eps <- getEps
   env <- getGblEnv
-  let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
+      -- We index into a UniqFM from Name -> elt, for tyCon it holds that
+      -- getUnique (tyConName tc) == getUnique tc. So we lookup using the
+      -- unique directly instead.
+  let lookup_completes ufm = lookupWithDefaultUFM_Directly ufm [] (getUnique tc)
       eps_matches_list = lookup_completes $ eps_complete_matches eps
       env_matches_list = lookup_completes $ ds_complete_matches env
   return $ eps_matches_list ++ env_matches_list
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index 7a213ce7ef..361ea04971 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -781,7 +781,7 @@ lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon]
 -- Unfortunately we need the extra bit of polymorphism and the unfortunate
 -- duplication of lookupVarInfo here.
 lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k =
-  case lookupUDFM env k of
+  case lookupUDFM_Directly env (getUnique k) of
     Nothing -> []
     Just (Indirect y) -> pmAltConSetElems (vi_neg (lookupVarInfo ts y))
     Just (Entry vi)   -> pmAltConSetElems (vi_neg vi)
diff --git a/compiler/GHC/HsToCore/PmCheck/Ppr.hs b/compiler/GHC/HsToCore/PmCheck/Ppr.hs
index 5b1fe16ba1..e4358e78b6 100644
--- a/compiler/GHC/HsToCore/PmCheck/Ppr.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Ppr.hs
@@ -98,7 +98,7 @@ substitution to the vectors before printing them out (see function `pprOne' in
 -- | Extract and assigns pretty names to constraint variables with refutable
 -- shapes.
 prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])
-prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList
+prettifyRefuts delta = listToUDFM_Directly . map attach_refuts . udfmToList
   where
     attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u))
 
diff --git a/compiler/GHC/HsToCore/PmCheck/Types.hs b/compiler/GHC/HsToCore/PmCheck/Types.hs
index 9267555380..2d551fc1aa 100644
--- a/compiler/GHC/HsToCore/PmCheck/Types.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Types.hs
@@ -6,6 +6,8 @@ Author: George Karachalias <george.karachalias@cs.kuleuven.be>
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ApplicativeDo #-}
 
 -- | Types used through-out pattern match checking. This module is mostly there
 -- to be imported from "GHC.Tc.Types". The exposed API is that of
@@ -458,11 +460,14 @@ setEntrySDIE :: SharedDIdEnv a -> Id -> a -> SharedDIdEnv a
 setEntrySDIE sdie@(SDIE env) x a =
   SDIE $ extendDVarEnv env (fst (lookupReprAndEntrySDIE sdie x)) (Entry a)
 
-traverseSDIE :: Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b)
-traverseSDIE f = fmap (SDIE . listToUDFM) . traverse g . udfmToList . unSDIE
+traverseSDIE :: forall a b f. Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b)
+traverseSDIE f = fmap (SDIE . listToUDFM_Directly) . traverse g . udfmToList . unSDIE
   where
+    g :: (Unique, Shared a) -> f (Unique, Shared b)
     g (u, Indirect y) = pure (u,Indirect y)
-    g (u, Entry a)    = (u,) . Entry <$> f a
+    g (u, Entry a)    = do
+        a' <- f a
+        pure (u,Entry a')
 
 instance Outputable a => Outputable (Shared a) where
   ppr (Indirect x) = ppr x