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.

2 files changed, 16 insertions, 14 deletions

diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index d92aa742af..1e2f7060f1 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -286,7 +286,7 @@ binaryInterfaceMagic platform
 -- The symbol table
 --
 
-putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
+putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
 putSymbolTable bh next_off symtab = do
     put_ bh next_off
     let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
@@ -327,7 +327,7 @@ fromOnDiskName nc (pid, mod_name, occ) =
                    new_cache  = extendNameCache cache mod occ name
                in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
 
-serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
+serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
 serialiseName bh name _ = do
     let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
     put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
@@ -399,7 +399,7 @@ getSymtabName _ncu _dict symtab bh = do
 
 data BinSymbolTable = BinSymbolTable {
         bin_symtab_next :: !FastMutInt, -- The next index to use
-        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
+        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
                                 -- indexed by Name
   }
 
@@ -410,13 +410,13 @@ allocateFastString :: BinDictionary -> FastString -> IO Word32
 allocateFastString BinDictionary { bin_dict_next = j_r,
                                    bin_dict_map  = out_r} f = do
     out <- readIORef out_r
-    let uniq = getUnique f
-    case lookupUFM out uniq of
+    let !uniq = getUnique f
+    case lookupUFM_Directly out uniq of
         Just (j, _)  -> return (fromIntegral j :: Word32)
         Nothing -> do
            j <- readFastMutInt j_r
            writeFastMutInt j_r (j + 1)
-           writeIORef out_r $! addToUFM out uniq (j, f)
+           writeIORef out_r $! addToUFM_Directly out uniq (j, f)
            return (fromIntegral j :: Word32)
 
 getDictFastString :: Dictionary -> BinHandle -> IO FastString
@@ -426,7 +426,7 @@ getDictFastString dict bh = do
 
 data BinDictionary = BinDictionary {
         bin_dict_next :: !FastMutInt, -- The next index to use
-        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
+        bin_dict_map  :: !(IORef (UniqFM FastString (Int,FastString)))
                                 -- indexed by FastString
   }
 
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 2fce4cd2ee..4fc3b9a331 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -2,6 +2,8 @@
 Binary serialization for .hie files.
 -}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns #-}
+
 module GHC.Iface.Ext.Binary
    ( readHieFile
    , readHieFileWithVersion
@@ -48,12 +50,12 @@ import GHC.Iface.Ext.Types
 
 data HieSymbolTable = HieSymbolTable
   { hie_symtab_next :: !FastMutInt
-  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))
+  , hie_symtab_map  :: !(IORef (UniqFM Name (Int, HieName)))
   }
 
 data HieDictionary = HieDictionary
   { hie_dict_next :: !FastMutInt -- The next index to use
-  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
+  , hie_dict_map  :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString
   }
 
 initBinMemSize :: Int
@@ -97,7 +99,7 @@ writeHieFile hie_file_path hiefile = do
   -- Make some initial state
   symtab_next <- newFastMutInt
   writeFastMutInt symtab_next 0
-  symtab_map <- newIORef emptyUFM
+  symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))
   let hie_symtab = HieSymbolTable {
                       hie_symtab_next = symtab_next,
                       hie_symtab_map  = symtab_map }
@@ -257,16 +259,16 @@ putFastString HieDictionary { hie_dict_next = j_r,
                               hie_dict_map  = out_r}  bh f
   = do
     out <- readIORef out_r
-    let unique = getUnique f
-    case lookupUFM out unique of
+    let !unique = getUnique f
+    case lookupUFM_Directly out unique of
         Just (j, _)  -> put_ bh (fromIntegral j :: Word32)
         Nothing -> do
            j <- readFastMutInt j_r
            put_ bh (fromIntegral j :: Word32)
            writeFastMutInt j_r (j + 1)
-           writeIORef out_r $! addToUFM out unique (j, f)
+           writeIORef out_r $! addToUFM_Directly out unique (j, f)
 
-putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()
+putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
 putSymbolTable bh next_off symtab = do
   put_ bh next_off
   let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))