Allow atomic update of NameCache in readHieFile

The situation arises in ghcide where multiple different threads may need to
update the name cache, therefore with the older interface it could happen
that you start reading a hie file with name cache A and produce name cache
A + B, but another thread in the meantime updated the namecache to A +
C. Therefore if you write the new namecache you will lose the A' updates
from the second thread.

Updates haddock submodule

4 files changed, 27 insertions, 25 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index b2649ff0d3..d01264ca55 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -178,7 +178,7 @@ import Control.DeepSeq (force)
 
 import GHC.Iface.Ext.Ast    ( mkHieFile )
 import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )
-import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
+import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))
 import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )
 
 #include "HsVersions.h"
@@ -438,8 +438,7 @@ extract_renamed_stuff mod_summary tc_result = do
                     putMsg dflags $ text "Got invalid scopes"
                     mapM_ (putMsg dflags) xs
               -- Roundtrip testing
-              nc <- readIORef $ hsc_NC hs_env
-              (file', _) <- readHieFile nc out_file
+              file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file
               case diffFile hieFile (hie_file_result file') of
                 [] ->
                   putMsg dflags $ text "Got no roundtrip errors"
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 9735f204dd..246e918946 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -12,6 +12,7 @@ module GHC.Iface.Ext.Binary
    , HieFileResult(..)
    , hieMagic
    , hieNameOcc
+   , NameCacheUpdater(..)
    )
 where
 
@@ -33,6 +34,7 @@ import GHC.Types.Unique.Supply    ( takeUniqFromSupply )
 import GHC.Types.Unique
 import GHC.Types.Unique.FM
 import GHC.Utils.Misc
+import GHC.Iface.Env (NameCacheUpdater(..))
 
 import qualified Data.Array as A
 import Data.IORef
@@ -189,23 +191,23 @@ type HieHeader = (Integer, ByteString)
 -- an existing `NameCache`. Allows you to specify
 -- which versions of hieFile to attempt to read.
 -- `Left` case returns the failing header versions.
-readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache))
-readHieFileWithVersion readVersion nc file = do
+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)
+readHieFileWithVersion readVersion ncu file = do
   bh0 <- readBinMem file
 
   (hieVersion, ghcVersion) <- readHieFileHeader file bh0
 
   if readVersion (hieVersion, ghcVersion)
   then do
-    (hieFile, nc') <- readHieFileContents bh0 nc
-    return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc')
+    hieFile <- readHieFileContents bh0 ncu
+    return $ Right (HieFileResult hieVersion ghcVersion hieFile)
   else return $ Left (hieVersion, ghcVersion)
 
 
 -- | Read a `HieFile` from a `FilePath`. Can use
 -- an existing `NameCache`.
-readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache)
-readHieFile nc file = do
+readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult
+readHieFile ncu file = do
 
   bh0 <- readBinMem file
 
@@ -219,8 +221,8 @@ readHieFile nc file = do
                     , show hieVersion
                     , "but got", show readHieVersion
                     ]
-  (hieFile, nc') <- readHieFileContents bh0 nc
-  return $ (HieFileResult hieVersion ghcVersion hieFile, nc')
+  hieFile <- readHieFileContents bh0 ncu
+  return $ HieFileResult hieVersion ghcVersion hieFile
 
 readBinLine :: BinHandle -> IO ByteString
 readBinLine bh = BS.pack . reverse <$> loop []
@@ -254,24 +256,24 @@ readHieFileHeader file bh0 = do
                         ]
       return (readHieVersion, ghcVersion)
 
-readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache)
-readHieFileContents bh0 nc = do
+readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile
+readHieFileContents bh0 ncu = do
 
   dict  <- get_dictionary bh0
 
   -- read the symbol table so we are capable of reading the actual data
-  (bh1, nc') <- do
+  bh1 <- do
       let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
                                                (getDictFastString dict)
-      (nc', symtab) <- get_symbol_table bh1
+      symtab <- get_symbol_table bh1
       let bh1' = setUserData bh1
                $ newReadState (getSymTabName symtab)
                               (getDictFastString dict)
-      return (bh1', nc')
+      return bh1'
 
   -- load the actual data
   hiefile <- get bh1
-  return (hiefile, nc')
+  return hiefile
   where
     get_dictionary bin_handle = do
       dict_p <- get bin_handle
@@ -285,9 +287,9 @@ readHieFileContents bh0 nc = do
       symtab_p <- get bh1
       data_p'  <- tellBin bh1
       seekBin bh1 symtab_p
-      (nc', symtab) <- getSymbolTable bh1 nc
+      symtab <- getSymbolTable bh1 ncu
       seekBin bh1 data_p'
-      return (nc', symtab)
+      return symtab
 
 putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
 putFastString HieDictionary { hie_dict_next = j_r,
@@ -309,13 +311,14 @@ putSymbolTable bh next_off symtab = do
   let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
   mapM_ (putHieName bh) names
 
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable)
-getSymbolTable bh namecache = do
+getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
+getSymbolTable bh ncu = do
   sz <- get bh
   od_names <- replicateM sz (getHieName bh)
-  let arr = A.listArray (0,sz-1) names
-      (namecache', names) = mapAccumR fromHieName namecache od_names
-  return (namecache', arr)
+  updateNameCache ncu $ \nc ->
+    let arr = A.listArray (0,sz-1) names
+        (nc', names) = mapAccumR fromHieName nc od_names
+        in (nc',arr)
 
 getSymTabName :: SymbolTable -> BinHandle -> IO Name
 getSymTabName st bh = do
diff --git a/testsuite/tests/hiefile/should_run/PatTypes.hs b/testsuite/tests/hiefile/should_run/PatTypes.hs
index 25803d0e47..9f181c8577 100644
--- a/testsuite/tests/hiefile/should_run/PatTypes.hs
+++ b/testsuite/tests/hiefile/should_run/PatTypes.hs
@@ -57,7 +57,7 @@ main = do
   libdir:_ <- getArgs
   df <- dynFlagsForPrinting libdir
   nc <- makeNc
-  (hfr, nc') <- readHieFile nc "PatTypes.hie"
+  hfr <- readHieFile (NCU (\f -> pure $ snd $ f nc)) "PatTypes.hie"
   let hf = hie_file_result hfr
   forM_ [p1,p2,p3,p4] $ \point -> do
     putStr $ "At " ++ show point ++ ", got type: "
diff --git a/utils/haddock b/utils/haddock
-Subproject c60995fe05d9cc267e892448604b8b96a705ccc
+Subproject 97f301a63ea8461074bfaa1486eb798e4be65f1