From d85a7df7170aa9223d64222ff2c6cc113dd86a8b Mon Sep 17 00:00:00 2001
From: Zubin Duggal <zubin@cmi.ac.in>
Date: Sat, 2 May 2020 18:33:02 +0530
Subject: [PATCH] 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
---
compiler/GHC/Driver/Main.hs | 5 +--
compiler/GHC/Iface/Ext/Binary.hs | 45 ++++++++++---------
.../tests/hiefile/should_run/PatTypes.hs | 2 +-
utils/haddock | 2 +-
4 files changed, 28 insertions(+), 26 deletions(-)
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index b2649ff0d3d..d01264ca55c 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 9735f204dda..246e9189466 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 25803d0e478..9f181c85775 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
index c60995fe05d..97f301a63ea 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit c60995fe05d9cc267e892448604b8b96a705ccc7
+Subproject commit 97f301a63ea8461074bfaa1486eb798e4be65f15
--
GitLab