Consolidate NameCache extension logicwip/T19214

5 files changed, 34 insertions, 36 deletions

diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index e2a6f0a79b..4144fe0398 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -45,7 +45,6 @@ import GHC.Types.Name
 import GHC.Driver.Session
 import GHC.Platform.Profile
 import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
 import GHC.Utils.Panic
 import GHC.Utils.Binary as Binary
 import GHC.Types.SrcLoc
@@ -320,11 +319,7 @@ fromOnDiskName nc (pid, mod_name, occ) =
         cache = nsNames nc
     in case lookupOrigNameCache cache  mod occ of
            Just name -> (nc, name)
-           Nothing   ->
-               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
-                   name       = mkExternalName uniq mod occ noSrcSpan
-                   new_cache  = extendNameCache cache mod occ name
-               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
+           Nothing   -> allocNameInCache mod occ noSrcSpan nc
 
 serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
 serialiseName bh name _ = do
diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs
index 8ab3ce3da5..8b2b3d0ff1 100644
--- a/compiler/GHC/Iface/Env.hs
+++ b/compiler/GHC/Iface/Env.hs
@@ -6,7 +6,7 @@ module GHC.Iface.Env (
         newGlobalBinder, newInteractiveBinder,
         externaliseName,
         lookupIfaceTop,
-        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
+        lookupOrig, lookupOrigIO, lookupOrigNameCache,
         newIfaceName, newIfaceNames,
         extendIfaceIdEnv, extendIfaceTyVarEnv,
         tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
@@ -108,22 +108,13 @@ allocateGlobalBinder name_supply mod occ loc
         Just name | isWiredInName name
                   -> (name_supply, name)
                   | otherwise
-                  -> (new_name_supply, name')
+                  -> addNameToCache uniq mod occ loc name_supply
                   where
-                    uniq             = nameUnique name
-                    name'            = mkExternalName uniq mod occ loc
-                                       -- name' is like name, but with the right SrcSpan
-                    new_cache        = extendNameCache (nsNames name_supply) mod occ name'
-                    !new_name_supply = name_supply {nsNames = new_cache}
+                    uniq = nameUnique name
 
         -- Miss in the cache!
         -- Build a completely new Name, and put it in the cache
-        _ -> (new_name_supply, name)
-                  where
-                    (uniq, us')      = takeUniqFromSupply (nsUniqs name_supply)
-                    name             = mkExternalName uniq mod occ loc
-                    new_cache        = extendNameCache (nsNames name_supply) mod occ name
-                    !new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+        _ -> allocNameInCache mod occ loc name_supply
 
 ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
 ifaceExportNames exports = return exports
@@ -193,13 +184,7 @@ lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
 lookupNameCache mod occ name_cache =
   case lookupOrigNameCache (nsNames name_cache) mod occ of {
     Just name -> (name_cache, name);
-    Nothing   ->
-        case takeUniqFromSupply (nsUniqs name_cache) of {
-          (uniq, us) ->
-              let
-                name      = mkExternalName uniq mod occ noSrcSpan
-                new_cache = extendNameCache (nsNames name_cache) mod occ name
-              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}
+    Nothing   -> allocNameInCache mod occ noSrcSpan name_cache }
 
 externaliseName :: Module -> Name -> TcRnIf m n Name
 -- Take an Internal Name and make it an External one,
@@ -209,10 +194,8 @@ externaliseName mod name
              loc = nameSrcSpan name
              uniq = nameUnique name
        ; occ `seq` return ()  -- c.f. seq in newGlobalBinder
-       ; updNameCacheTc mod occ $ \ ns ->
-         let name' = mkExternalName uniq mod occ loc
-             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
-         in (ns', name') }
+       ; updNameCacheTc mod occ $ \ns -> addNameToCache uniq mod occ loc ns
+       }
 
 -- | Set the 'Module' of a 'Name'.
 setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 69aee26586..ef35e4efe5 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -319,11 +319,7 @@ fromHieName nc (ExternalName mod occ span) =
     let cache = nsNames nc
     in case lookupOrigNameCache cache mod occ of
          Just name -> (nc, name)
-         Nothing ->
-           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
-               name       = mkExternalName uniq mod occ span
-               new_cache  = extendNameCache cache mod occ name
-           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
+         Nothing   -> allocNameInCache mod occ span nc
 fromHieName nc (LocalName occ span) =
     let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
         name       = mkInternalName uniq occ span
diff --git a/compiler/GHC/Types/Name/Cache.hs b/compiler/GHC/Types/Name/Cache.hs
index f69eeb9e2f..897e6fbad5 100644
--- a/compiler/GHC/Types/Name/Cache.hs
+++ b/compiler/GHC/Types/Name/Cache.hs
@@ -5,7 +5,8 @@
 module GHC.Types.Name.Cache
     ( lookupOrigNameCache
     , extendOrigNameCache
-    , extendNameCache
+    , allocNameInCache
+    , addNameToCache
     , initNameCache
     , NameCache(..), OrigNameCache
     ) where
@@ -18,10 +19,13 @@ import GHC.Types.Unique.Supply
 import GHC.Builtin.Types
 import GHC.Builtin.Names
 
+import GHC.Types.SrcLoc
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
+import GHC.Exts (inline)
+
 #include "HsVersions.h"
 
 {-
@@ -103,6 +107,26 @@ extendNameCache nc mod occ !name
   where
     combine _ occ_env = extendOccEnv occ_env occ name
 
+-- | Allocate a fresh 'Unique' from the 'NameCache' and extend it with a new
+-- 'OccName', returning the finished 'Name'.
+allocNameInCache :: Module -> OccName -> SrcSpan
+                 -> NameCache -> (NameCache, Name)
+allocNameInCache mod occ loc nc
+  = inline addNameToCache uniq mod occ loc $
+    nc { nsUniqs = us' }
+  where
+    !(uniq, us') = takeUniqFromSupply (nsUniqs nc)
+
+-- | Extend the 'NameCache' with a new 'OccName' with the given 'Unique',
+-- returning the finished 'Name'
+addNameToCache :: Unique -> Module -> OccName -> SrcSpan
+               -> NameCache -> (NameCache, Name)
+addNameToCache uniq mod occ loc nc
+  = (nc { nsNames = extendNameCache (nsNames nc) mod occ name }, name)
+  where
+    !name = mkExternalName uniq mod occ loc
+
+
 -- | The NameCache makes sure that there is just one Unique assigned for
 -- each original name; i.e. (module-name, occ-name) pair and provides
 -- something of a lookup mechanism for those names.
diff --git a/utils/haddock b/utils/haddock
-Subproject e7ee7957a7ac746cfa05d7218fe0c2d1fd27f56
+Subproject c180e2d4c519ade6e5f531957d0b087528f4df2