Use a global namecache to read .hie files (#677)

* Use global NameCache for reading HIE files

Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com>

* ignore hlint

* redundant imports

* Use hie files as source of truth for name source spans.

Since we started reusing `.hi` files, this exposes a bug where definitions
aren't available since a bad source span from the `.hi` file gets put into
the NameCache. We rectify by ensuring the span in the NameCache always matches
the one from the `.hie` file.

This has surfaced because an interaction between the commit which uses `.hi`
instead of retypechecking and the change to use the shared global NameCache
to read `.hie` files.

* Add test for missing definitions

Co-authored-by: Matthew Pickering <matthewtpickering@gmail.com>

exe/Main.hs

@@ -203,12 +203,12 @@ cradleToSessionOpts cradle file = do
         -- message about the fact that the file is being ignored.
         CradleNone -> return (Left [])
 
-emptyHscEnv :: IO HscEnv
-emptyHscEnv = do
+emptyHscEnv :: IORef NameCache -> IO HscEnv
+emptyHscEnv nc = do
     libdir <- getLibdir
     env <- runGhc (Just libdir) getSession
     initDynLinker env
-    pure env
+    pure $ setNameCache nc env
 
 -- | Convert a target to a list of potential absolute paths.
 -- A TargetModule can be anywhere listed by the supplied include
@@ -262,7 +262,7 @@ loadSession dir = do
     InstallationMismatch{..} ->
         return $ returnWithVersion $ \fp -> return (([renderPackageSetupException compileTime fp GhcVersionMismatch{..}], Nothing),[])
     InstallationChecked compileTime ghcLibCheck -> return $ do
-      ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress} <- getShakeExtras
+      ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress, ideNc} <- getShakeExtras
       IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions
 
       -- Create a new HscEnv from a hieYaml root and a set of options
@@ -273,7 +273,7 @@ loadSession dir = do
                        -> IO (HscEnv, ComponentInfo, [ComponentInfo])
           packageSetup (hieYaml, cfp, opts) = do
             -- Parse DynFlags for the newly discovered component
-            hscEnv <- emptyHscEnv
+            hscEnv <- emptyHscEnv ideNc
             (df, targets) <- evalGhcEnv hscEnv $
                 setOptions opts (hsc_dflags hscEnv)
             let deps = componentDependencies opts ++ maybeToList hieYaml
@@ -317,9 +317,7 @@ loadSession dir = do
                 -- It's important to keep the same NameCache though for reasons
                 -- that I do not fully understand
                 logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))
-                hscEnv <- case oldDeps of
-                            Nothing -> emptyHscEnv
-                            Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv
+                hscEnv <- emptyHscEnv ideNc
                 newHscEnv <-
                   -- Add the options for the current component to the HscEnv
                   evalGhcEnv hscEnv $ do

ghcide.cabal

@@ -159,10 +159,12 @@ library
       hs-source-dirs: src-ghc88
       other-modules:
         Development.IDE.GHC.HieAst
+        Development.IDE.GHC.HieBin
     if (impl(ghc > 8.9))
       hs-source-dirs: src-ghc810
       other-modules:
         Development.IDE.GHC.HieAst
+        Development.IDE.GHC.HieBin
     ghc-options: -Wall -Wno-name-shadowing
 
 executable ghcide-test-preprocessor

src-ghc810/Development/IDE/GHC/HieBin.hs

@@ -0,0 +1,399 @@
+{-
+Binary serialization for .hie files.
+-}
+{- HLINT ignore -}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Development.IDE.GHC.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc,NameCacheUpdater(..)) where
+
+import GHC.Settings               ( maybeRead )
+
+import Config                     ( cProjectVersion )
+import Binary
+import BinIface                   ( getDictFastString )
+import FastMutInt
+import FastString                 ( FastString )
+import Module                     ( Module )
+import Name
+import NameCache
+import Outputable
+import PrelInfo
+import SrcLoc
+import UniqSupply                 ( takeUniqFromSupply )
+import Unique
+import UniqFM
+import IfaceEnv
+
+import qualified Data.Array as A
+import Data.IORef
+import Data.ByteString            ( ByteString )
+import qualified Data.ByteString  as BS
+import qualified Data.ByteString.Char8 as BSC
+import Data.List                  ( mapAccumR )
+import Data.Word                  ( Word8, Word32 )
+import Control.Monad              ( replicateM, when )
+import System.Directory           ( createDirectoryIfMissing )
+import System.FilePath            ( takeDirectory )
+
+import HieTypes
+
+-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
+-- these two types.
+data HieName
+  = ExternalName !Module !OccName !SrcSpan
+  | LocalName !OccName !SrcSpan
+  | KnownKeyName !Unique
+  deriving (Eq)
+
+instance Ord HieName where
+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)
+  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)
+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
+    -- Not actually non determinstic as it is a KnownKey
+  compare ExternalName{} _ = LT
+  compare LocalName{} ExternalName{} = GT
+  compare LocalName{} _ = LT
+  compare KnownKeyName{} _ = GT
+
+instance Outputable HieName where
+  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
+  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
+  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
+
+hieNameOcc :: HieName -> OccName
+hieNameOcc (ExternalName _ occ _) = occ
+hieNameOcc (LocalName occ _) = occ
+hieNameOcc (KnownKeyName u) =
+  case lookupKnownKeyName u of
+    Just n -> nameOccName n
+    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
+                        (ppr (unpkUnique u))
+
+
+data HieSymbolTable = HieSymbolTable
+  { hie_symtab_next :: !FastMutInt
+  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))
+  }
+
+data HieDictionary = HieDictionary
+  { hie_dict_next :: !FastMutInt -- The next index to use
+  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
+  }
+
+initBinMemSize :: Int
+initBinMemSize = 1024*1024
+
+-- | The header for HIE files - Capital ASCII letters "HIE".
+hieMagic :: [Word8]
+hieMagic = [72,73,69]
+
+hieMagicLen :: Int
+hieMagicLen = length hieMagic
+
+ghcVersion :: ByteString
+ghcVersion = BSC.pack cProjectVersion
+
+putBinLine :: BinHandle -> ByteString -> IO ()
+putBinLine bh xs = do
+  mapM_ (putByte bh) $ BS.unpack xs
+  putByte bh 10 -- newline char
+
+-- | Write a `HieFile` to the given `FilePath`, with a proper header and
+-- symbol tables for `Name`s and `FastString`s
+writeHieFile :: FilePath -> HieFile -> IO ()
+writeHieFile hie_file_path hiefile = do
+  bh0 <- openBinMem initBinMemSize
+
+  -- Write the header: hieHeader followed by the
+  -- hieVersion and the GHC version used to generate this file
+  mapM_ (putByte bh0) hieMagic
+  putBinLine bh0 $ BSC.pack $ show hieVersion
+  putBinLine bh0 $ ghcVersion
+
+  -- remember where the dictionary pointer will go
+  dict_p_p <- tellBin bh0
+  put_ bh0 dict_p_p
+
+  -- remember where the symbol table pointer will go
+  symtab_p_p <- tellBin bh0
+  put_ bh0 symtab_p_p
+
+  -- Make some intial state
+  symtab_next <- newFastMutInt
+  writeFastMutInt symtab_next 0
+  symtab_map <- newIORef emptyUFM
+  let hie_symtab = HieSymbolTable {
+                      hie_symtab_next = symtab_next,
+                      hie_symtab_map  = symtab_map }
+  dict_next_ref <- newFastMutInt
+  writeFastMutInt dict_next_ref 0
+  dict_map_ref <- newIORef emptyUFM
+  let hie_dict = HieDictionary {
+                      hie_dict_next = dict_next_ref,
+                      hie_dict_map  = dict_map_ref }
+
+  -- put the main thing
+  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
+                                           (putName hie_symtab)
+                                           (putFastString hie_dict)
+  put_ bh hiefile
+
+  -- write the symtab pointer at the front of the file
+  symtab_p <- tellBin bh
+  putAt bh symtab_p_p symtab_p
+  seekBin bh symtab_p
+
+  -- write the symbol table itself
+  symtab_next' <- readFastMutInt symtab_next
+  symtab_map'  <- readIORef symtab_map
+  putSymbolTable bh symtab_next' symtab_map'
+
+  -- write the dictionary pointer at the front of the file
+  dict_p <- tellBin bh
+  putAt bh dict_p_p dict_p
+  seekBin bh dict_p
+
+  -- write the dictionary itself
+  dict_next <- readFastMutInt dict_next_ref
+  dict_map  <- readIORef dict_map_ref
+  putDictionary bh dict_next dict_map
+
+  -- and send the result to the file
+  createDirectoryIfMissing True (takeDirectory hie_file_path)
+  writeBinMem bh hie_file_path
+  return ()
+
+data HieFileResult
+  = HieFileResult
+  { hie_file_result_version :: Integer
+  , hie_file_result_ghc_version :: ByteString
+  , hie_file_result :: HieFile
+  }
+
+type HieHeader = (Integer, ByteString)
+
+-- | Read a `HieFile` from a `FilePath`. Can use
+-- 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) -> 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 <- 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 :: NameCacheUpdater -> FilePath -> IO HieFileResult
+readHieFile ncu file = do
+
+  bh0 <- readBinMem file
+
+  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0
+
+  -- Check if the versions match
+  when (readHieVersion /= hieVersion) $
+    panic $ unwords ["readHieFile: hie file versions don't match for file:"
+                    , file
+                    , "Expected"
+                    , show hieVersion
+                    , "but got", show readHieVersion
+                    ]
+  hieFile <- readHieFileContents bh0 ncu
+  return $ HieFileResult hieVersion ghcVersion hieFile
+
+readBinLine :: BinHandle -> IO ByteString
+readBinLine bh = BS.pack . reverse <$> loop []
+  where
+    loop acc = do
+      char <- get bh :: IO Word8
+      if char == 10 -- ASCII newline '\n'
+      then return acc
+      else loop (char : acc)
+
+readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
+readHieFileHeader file bh0 = do
+  -- Read the header
+  magic <- replicateM hieMagicLen (get bh0)
+  version <- BSC.unpack <$> readBinLine bh0
+  case maybeRead version of
+    Nothing ->
+      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"
+                      , show version
+                      ]
+    Just readHieVersion -> do
+      ghcVersion <- readBinLine bh0
+
+      -- Check if the header is valid
+      when (magic /= hieMagic) $
+        panic $ unwords ["readHieFileHeader: headers don't match for file:"
+                        , file
+                        , "Expected"
+                        , show hieMagic
+                        , "but got", show magic
+                        ]
+      return (readHieVersion, ghcVersion)
+
+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 <- do
+      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
+                                               (getDictFastString dict)
+      symtab <- get_symbol_table bh1
+      let bh1' = setUserData bh1
+               $ newReadState (getSymTabName symtab)
+                              (getDictFastString dict)
+      return bh1'
+
+  -- load the actual data
+  hiefile <- get bh1
+  return hiefile
+  where
+    get_dictionary bin_handle = do
+      dict_p <- get bin_handle
+      data_p <- tellBin bin_handle
+      seekBin bin_handle dict_p
+      dict <- getDictionary bin_handle
+      seekBin bin_handle data_p
+      return dict
+
+    get_symbol_table bh1 = do
+      symtab_p <- get bh1
+      data_p'  <- tellBin bh1
+      seekBin bh1 symtab_p
+      symtab <- getSymbolTable bh1 ncu
+      seekBin bh1 data_p'
+      return symtab
+
+putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
+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
+        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)
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (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))
+  mapM_ (putHieName bh) names
+
+getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
+getSymbolTable bh ncu = do
+  sz <- get bh
+  od_names <- replicateM sz (getHieName bh)
+  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
+  i :: Word32 <- get bh
+  return $ st A.! (fromIntegral i)
+
+putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
+putName (HieSymbolTable next ref) bh name = do
+  symmap <- readIORef ref
+  case lookupUFM symmap name of
+    Just (off, ExternalName mod occ (UnhelpfulSpan _))
+      | isGoodSrcSpan (nameSrcSpan name) -> do
+      let hieName = ExternalName mod occ (nameSrcSpan name)
+      writeIORef ref $! addToUFM symmap name (off, hieName)
+      put_ bh (fromIntegral off :: Word32)
+    Just (off, LocalName _occ span)
+      | notLocal (toHieName name) || nameSrcSpan name /= span -> do
+      writeIORef ref $! addToUFM symmap name (off, toHieName name)
+      put_ bh (fromIntegral off :: Word32)
+    Just (off, _) -> put_ bh (fromIntegral off :: Word32)
+    Nothing -> do
+        off <- readFastMutInt next
+        writeFastMutInt next (off+1)
+        writeIORef ref $! addToUFM symmap name (off, toHieName name)
+        put_ bh (fromIntegral off :: Word32)
+
+  where
+    notLocal :: HieName -> Bool
+    notLocal LocalName{} = False
+    notLocal _ = True
+
+
+-- ** Converting to and from `HieName`'s
+
+toHieName :: Name -> HieName
+toHieName name
+  | isKnownKeyName name = KnownKeyName (nameUnique name)
+  | isExternalName name = ExternalName (nameModule name)
+                                       (nameOccName name)
+                                       (nameSrcSpan name)
+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
+
+fromHieName :: NameCache -> HieName -> (NameCache, Name)
+fromHieName nc (ExternalName mod occ span) =
+    let cache = nsNames nc
+    in case lookupOrigNameCache cache mod occ of
+         Just name
+           | nameSrcSpan name == span -> (nc, name)
+           | otherwise ->
+             let name' = setNameLoc name span
+                 new_cache = extendNameCache cache mod occ name'
+             in ( nc{ nsNames = new_cache }, 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 )
+fromHieName nc (LocalName occ span) =
+    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+        name       = mkInternalName uniq occ span
+    in ( nc{ nsUniqs = us }, name )
+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of
+    Nothing -> pprPanic "fromHieName:unknown known-key unique"
+                        (ppr (unpkUnique u))
+    Just n -> (nc, n)
+
+-- ** Reading and writing `HieName`'s
+
+putHieName :: BinHandle -> HieName -> IO ()
+putHieName bh (ExternalName mod occ span) = do
+  putByte bh 0
+  put_ bh (mod, occ, span)
+putHieName bh (LocalName occName span) = do
+  putByte bh 1
+  put_ bh (occName, span)
+putHieName bh (KnownKeyName uniq) = do
+  putByte bh 2
+  put_ bh $ unpkUnique uniq
+
+getHieName :: BinHandle -> IO HieName
+getHieName bh = do
+  t <- getByte bh
+  case t of
+    0 -> do
+      (modu, occ, span) <- get bh
+      return $ ExternalName modu occ span
+    1 -> do
+      (occ, span) <- get bh
+      return $ LocalName occ span
+    2 -> do
+      (c,i) <- get bh
+      return $ KnownKeyName $ mkUnique c i
+    _ -> panic "HieBin.getHieName: invalid tag"

src-ghc88/Development/IDE/GHC/HieBin.hs

@@ -0,0 +1,389 @@
+{-
+Binary serialization for .hie files.
+-}
+{- HLINT ignore -}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Development.IDE.GHC.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic,NameCacheUpdater(..)) where
+
+import Config                     ( cProjectVersion )
+import Binary
+import BinIface                   ( getDictFastString )
+import FastMutInt
+import FastString                 ( FastString )
+import Module                     ( Module )
+import Name
+import NameCache
+import Outputable
+import PrelInfo
+import SrcLoc
+import UniqSupply                 ( takeUniqFromSupply )
+import Util                       ( maybeRead )
+import Unique
+import UniqFM
+import IfaceEnv
+
+import qualified Data.Array as A
+import Data.IORef
+import Data.ByteString            ( ByteString )
+import qualified Data.ByteString  as BS
+import qualified Data.ByteString.Char8 as BSC
+import Data.List                  ( mapAccumR )
+import Data.Word                  ( Word8, Word32 )
+import Control.Monad              ( replicateM, when )
+import System.Directory           ( createDirectoryIfMissing )
+import System.FilePath            ( takeDirectory )
+
+import HieTypes
+
+-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
+-- these two types.
+data HieName
+  = ExternalName !Module !OccName !SrcSpan
+  | LocalName !OccName !SrcSpan
+  | KnownKeyName !Unique
+  deriving (Eq)
+
+instance Ord HieName where
+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)
+  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)
+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
+    -- Not actually non determinstic as it is a KnownKey
+  compare ExternalName{} _ = LT
+  compare LocalName{} ExternalName{} = GT
+  compare LocalName{} _ = LT
+  compare KnownKeyName{} _ = GT
+
+instance Outputable HieName where
+  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
+  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
+  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
+
+
+data HieSymbolTable = HieSymbolTable
+  { hie_symtab_next :: !FastMutInt
+  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))
+  }
+
+data HieDictionary = HieDictionary
+  { hie_dict_next :: !FastMutInt -- The next index to use
+  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
+  }
+
+initBinMemSize :: Int
+initBinMemSize = 1024*1024
+
+-- | The header for HIE files - Capital ASCII letters "HIE".
+hieMagic :: [Word8]
+hieMagic = [72,73,69]
+
+hieMagicLen :: Int
+hieMagicLen = length hieMagic
+
+ghcVersion :: ByteString
+ghcVersion = BSC.pack cProjectVersion
+
+putBinLine :: BinHandle -> ByteString -> IO ()
+putBinLine bh xs = do
+  mapM_ (putByte bh) $ BS.unpack xs
+  putByte bh 10 -- newline char
+
+-- | Write a `HieFile` to the given `FilePath`, with a proper header and
+-- symbol tables for `Name`s and `FastString`s
+writeHieFile :: FilePath -> HieFile -> IO ()
+writeHieFile hie_file_path hiefile = do
+  bh0 <- openBinMem initBinMemSize
+
+  -- Write the header: hieHeader followed by the
+  -- hieVersion and the GHC version used to generate this file
+  mapM_ (putByte bh0) hieMagic
+  putBinLine bh0 $ BSC.pack $ show hieVersion
+  putBinLine bh0 $ ghcVersion
+
+  -- remember where the dictionary pointer will go
+  dict_p_p <- tellBin bh0
+  put_ bh0 dict_p_p
+
+  -- remember where the symbol table pointer will go
+  symtab_p_p <- tellBin bh0
+  put_ bh0 symtab_p_p
+
+  -- Make some intial state
+  symtab_next <- newFastMutInt
+  writeFastMutInt symtab_next 0
+  symtab_map <- newIORef emptyUFM
+  let hie_symtab = HieSymbolTable {
+                      hie_symtab_next = symtab_next,
+                      hie_symtab_map  = symtab_map }
+  dict_next_ref <- newFastMutInt
+  writeFastMutInt dict_next_ref 0
+  dict_map_ref <- newIORef emptyUFM
+  let hie_dict = HieDictionary {
+                      hie_dict_next = dict_next_ref,
+                      hie_dict_map  = dict_map_ref }
+
+  -- put the main thing
+  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
+                                           (putName hie_symtab)
+                                           (putFastString hie_dict)
+  put_ bh hiefile
+
+  -- write the symtab pointer at the front of the file
+  symtab_p <- tellBin bh
+  putAt bh symtab_p_p symtab_p
+  seekBin bh symtab_p
+
+  -- write the symbol table itself
+  symtab_next' <- readFastMutInt symtab_next
+  symtab_map'  <- readIORef symtab_map
+  putSymbolTable bh symtab_next' symtab_map'
+
+  -- write the dictionary pointer at the front of the file
+  dict_p <- tellBin bh
+  putAt bh dict_p_p dict_p
+  seekBin bh dict_p
+
+  -- write the dictionary itself
+  dict_next <- readFastMutInt dict_next_ref
+  dict_map  <- readIORef dict_map_ref
+  putDictionary bh dict_next dict_map
+
+  -- and send the result to the file
+  createDirectoryIfMissing True (takeDirectory hie_file_path)
+  writeBinMem bh hie_file_path
+  return ()
+
+data HieFileResult
+  = HieFileResult
+  { hie_file_result_version :: Integer
+  , hie_file_result_ghc_version :: ByteString
+  , hie_file_result :: HieFile
+  }
+
+type HieHeader = (Integer, ByteString)
+
+-- | Read a `HieFile` from a `FilePath`. Can use
+-- 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) -> 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 <- 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 :: NameCacheUpdater -> FilePath -> IO HieFileResult
+readHieFile ncu file = do
+
+  bh0 <- readBinMem file
+
+  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0
+
+  -- Check if the versions match
+  when (readHieVersion /= hieVersion) $
+    panic $ unwords ["readHieFile: hie file versions don't match for file:"
+                    , file
+                    , "Expected"
+                    , show hieVersion
+                    , "but got", show readHieVersion
+                    ]
+  hieFile <- readHieFileContents bh0 ncu
+  return $ HieFileResult hieVersion ghcVersion hieFile
+
+readBinLine :: BinHandle -> IO ByteString
+readBinLine bh = BS.pack . reverse <$> loop []
+  where
+    loop acc = do
+      char <- get bh :: IO Word8
+      if char == 10 -- ASCII newline '\n'
+      then return acc
+      else loop (char : acc)
+
+readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
+readHieFileHeader file bh0 = do
+  -- Read the header
+  magic <- replicateM hieMagicLen (get bh0)
+  version <- BSC.unpack <$> readBinLine bh0
+  case maybeRead version of
+    Nothing ->
+      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"
+                      , show version
+                      ]
+    Just readHieVersion -> do
+      ghcVersion <- readBinLine bh0
+
+      -- Check if the header is valid
+      when (magic /= hieMagic) $
+        panic $ unwords ["readHieFileHeader: headers don't match for file:"
+                        , file
+                        , "Expected"
+                        , show hieMagic
+                        , "but got", show magic
+                        ]
+      return (readHieVersion, ghcVersion)
+
+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 <- do
+      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
+                                               (getDictFastString dict)
+      symtab <- get_symbol_table bh1
+      let bh1' = setUserData bh1
+               $ newReadState (getSymTabName symtab)
+                              (getDictFastString dict)
+      return bh1'
+
+  -- load the actual data
+  hiefile <- get bh1
+  return hiefile
+  where
+    get_dictionary bin_handle = do
+      dict_p <- get bin_handle
+      data_p <- tellBin bin_handle
+      seekBin bin_handle dict_p
+      dict <- getDictionary bin_handle
+      seekBin bin_handle data_p
+      return dict
+
+    get_symbol_table bh1 = do
+      symtab_p <- get bh1
+      data_p'  <- tellBin bh1
+      seekBin bh1 symtab_p
+      symtab <- getSymbolTable bh1 ncu
+      seekBin bh1 data_p'
+      return symtab
+
+putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
+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
+        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)
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (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))
+  mapM_ (putHieName bh) names
+
+getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
+getSymbolTable bh ncu = do
+  sz <- get bh
+  od_names <- replicateM sz (getHieName bh)
+  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
+  i :: Word32 <- get bh
+  return $ st A.! (fromIntegral i)
+
+putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
+putName (HieSymbolTable next ref) bh name = do
+  symmap <- readIORef ref
+  case lookupUFM symmap name of
+    Just (off, ExternalName mod occ (UnhelpfulSpan _))
+      | isGoodSrcSpan (nameSrcSpan name) -> do
+      let hieName = ExternalName mod occ (nameSrcSpan name)
+      writeIORef ref $! addToUFM symmap name (off, hieName)
+      put_ bh (fromIntegral off :: Word32)
+    Just (off, LocalName _occ span)
+      | notLocal (toHieName name) || nameSrcSpan name /= span -> do
+      writeIORef ref $! addToUFM symmap name (off, toHieName name)
+      put_ bh (fromIntegral off :: Word32)
+    Just (off, _) -> put_ bh (fromIntegral off :: Word32)
+    Nothing -> do
+        off <- readFastMutInt next
+        writeFastMutInt next (off+1)
+        writeIORef ref $! addToUFM symmap name (off, toHieName name)
+        put_ bh (fromIntegral off :: Word32)
+
+  where
+    notLocal :: HieName -> Bool
+    notLocal LocalName{} = False
+    notLocal _ = True
+
+
+-- ** Converting to and from `HieName`'s
+
+toHieName :: Name -> HieName
+toHieName name
+  | isKnownKeyName name = KnownKeyName (nameUnique name)
+  | isExternalName name = ExternalName (nameModule name)
+                                       (nameOccName name)
+                                       (nameSrcSpan name)
+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
+
+fromHieName :: NameCache -> HieName -> (NameCache, Name)
+fromHieName nc (ExternalName mod occ span) =
+    let cache = nsNames nc
+    in case lookupOrigNameCache cache mod occ of
+         Just name
+           | nameSrcSpan name == span -> (nc, name)
+           | otherwise ->
+             let name' = setNameLoc name span
+                 new_cache = extendNameCache cache mod occ name'
+             in ( nc{ nsNames = new_cache }, 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 )
+fromHieName nc (LocalName occ span) =
+    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+        name       = mkInternalName uniq occ span
+    in ( nc{ nsUniqs = us }, name )
+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of
+    Nothing -> pprPanic "fromHieName:unknown known-key unique"
+                        (ppr (unpkUnique u))
+    Just n -> (nc, n)
+
+-- ** Reading and writing `HieName`'s
+
+putHieName :: BinHandle -> HieName -> IO ()
+putHieName bh (ExternalName mod occ span) = do
+  putByte bh 0
+  put_ bh (mod, occ, span)
+putHieName bh (LocalName occName span) = do
+  putByte bh 1
+  put_ bh (occName, span)
+putHieName bh (KnownKeyName uniq) = do
+  putByte bh 2
+  put_ bh $ unpkUnique uniq
+
+getHieName :: BinHandle -> IO HieName
+getHieName bh = do
+  t <- getByte bh
+  case t of
+    0 -> do
+      (modu, occ, span) <- get bh
+      return $ ExternalName modu occ span
+    1 -> do
+      (occ, span) <- get bh
+      return $ LocalName occ span
+    2 -> do
+      (c,i) <- get bh
+      return $ KnownKeyName $ mkUnique c i
+    _ -> panic "HieBin.getHieName: invalid tag"

src/Development/IDE/Core/Compile.hs

@@ -60,7 +60,6 @@ import           GhcPlugins                     as GHC hiding (fst3, (<>))
 import qualified HeaderInfo                     as Hdr
 import           HscMain                        (hscInteractive, hscSimplify)
 import           MkIface
-import           NameCache
 import           StringBuffer                   as SB
 import           TcRnMonad (initIfaceLoad, tcg_th_coreplugins)
 import           TcIface                        (typecheckIface)
@@ -588,11 +587,9 @@ removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImpor
     do_one_import l = l
 #endif
 
-loadHieFile :: FilePath -> IO GHC.HieFile
-loadHieFile f = do
-        u <- mkSplitUniqSupply 'a'
-        let nameCache = initNameCache u []
-        fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f
+loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
+loadHieFile ncu f = do
+  GHC.hie_file_result <$> GHC.readHieFile ncu f
 
 -- | Retuns an up-to-date module interface, regenerating if needed.
 --   Assumes file exists.

src/Development/IDE/Core/Rules.hs

@@ -178,7 +178,8 @@ getHomeHieFile f = do
 
   if isUpToDate
     then do
-      hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)
+      ncu <- mkUpdater
+      hf <- liftIO $ whenMaybe isUpToDate (loadHieFile ncu hie_f)
       MaybeT $ return hf
     else do
       wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do
@@ -186,7 +187,8 @@ getHomeHieFile f = do
         pm <- use_ GetParsedModule f
         typeCheckRuleDefinition hsc pm DoGenerateInterfaceFiles
       _ <- MaybeT $ liftIO $ timeout 1 wait
-      liftIO $ loadHieFile hie_f
+      ncu <- mkUpdater
+      liftIO $ loadHieFile ncu hie_f
 
 
 getPackageHieFile :: ShakeExtras
@@ -203,10 +205,11 @@ getPackageHieFile ide mod file = do
             hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
             path    <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
             case (hieFile, path) of
-                (Just hiePath, Just modPath) -> MaybeT $
+                (Just hiePath, Just modPath) -> do
                     -- deliberately loaded outside the Shake graph
                     -- to avoid dependencies on non-workspace files
-                        liftIO $ Just . (, modPath) <$> loadHieFile hiePath
+                        ncu <- mkUpdater
+                        MaybeT $ liftIO $ Just . (, modPath) <$> loadHieFile ncu hiePath
                 _ -> MaybeT $ return Nothing
         _ -> MaybeT $ return Nothing
 

src/Development/IDE/Core/Shake.hs

@@ -56,7 +56,8 @@ module Development.IDE.Core.Shake(
     WithProgressFunc, WithIndefiniteProgressFunc,
     ProgressEvent(..),
     DelayedAction, mkDelayedAction,
-    IdeAction(..), runIdeAction
+    IdeAction(..), runIdeAction,
+    mkUpdater
     ) where
 
 import           Development.Shake hiding (ShakeValue, doesFileExist, Info)
@@ -75,6 +76,7 @@ import qualified Data.Text as T
 import Data.Tuple.Extra
 import Data.Unique
 import Development.IDE.Core.Debouncer
+import Development.IDE.GHC.Compat ( NameCacheUpdater(..), upNameCache )
 import Development.IDE.Core.PositionMapping
 import Development.IDE.Types.Logger hiding (Priority)
 import qualified Development.IDE.Types.Logger as Logger
@@ -105,8 +107,13 @@ import Data.Foldable (traverse_)
 import qualified Control.Monad.STM as STM
 import Control.Monad.IO.Class
 import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
 import Data.Traversable
 
+import Data.IORef
+import NameCache
+import UniqSupply
+import PrelInfo
 
 -- information we stash inside the shakeExtra field
 data ShakeExtras = ShakeExtras
@@ -138,6 +145,7 @@ data ShakeExtras = ShakeExtras
     ,withIndefiniteProgress :: WithIndefiniteProgressFunc
     -- ^ Same as 'withProgress', but for processes that do not report the percentage complete
     ,restartShakeSession :: [DelayedAction ()] -> IO ()
+    , ideNc :: IORef NameCache
     }
 
 type WithProgressFunc = forall a.
@@ -373,6 +381,8 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
   shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) opts rules = mdo
 
     inProgress <- newVar HMap.empty
+    us <- mkSplitUniqSupply 'r'
+    ideNc <- newIORef (initNameCache us knownKeyNames)
     (shakeExtras, stopProgressReporting) <- do
         globals <- newVar HMap.empty
         state <- newVar HMap.empty
@@ -708,6 +718,11 @@ runIdeAction _herald s i = runReaderT (runIdeActionT i) s
 askShake :: IdeAction ShakeExtras
 askShake = ask
 
+mkUpdater :: MaybeT IdeAction NameCacheUpdater
+mkUpdater = do
+  ref <- lift $ ideNc <$> askShake
+  pure $ NCU (upNameCache ref)
+
 -- | A (maybe) stale result now, and an up to date one later
 data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  }
 

src/Development/IDE/GHC/Compat.hs

@@ -12,9 +12,9 @@
 module Development.IDE.GHC.Compat(
     getHeaderImports,
     HieFileResult(..),
-    HieFile,
+    HieFile(..),
+    NameCacheUpdater(..),
     hieExportNames,
-    hie_module,
     mkHieFile,
     writeHieFile,
     readHieFile,
@@ -49,7 +49,13 @@ module Development.IDE.GHC.Compat(
     HasSrcSpan,
     getLoc,
 
-    module GHC
+    upNameCache,
+
+    module GHC,
+#if MIN_GHC_API_VERSION(8,8,0)
+    module HieTypes,
+    module HieUtils,
+#endif
     ) where
 
 import StringBuffer
@@ -58,6 +64,9 @@ import FieldLabel
 import Fingerprint (Fingerprint)
 import qualified Module
 import Packages
+import Data.IORef
+import HscTypes
+import NameCache
 
 import qualified GHC
 import GHC hiding (
@@ -84,13 +93,10 @@ import Avail
 import ErrUtils (ErrorMessages)
 import FastString (FastString)
 
-#if MIN_GHC_API_VERSION(8,10,0)
-import HscTypes (mi_mod_hash)
-#endif
-
 #if MIN_GHC_API_VERSION(8,8,0)
 import Development.IDE.GHC.HieAst (mkHieFile)
-import HieBin
+import Development.IDE.GHC.HieBin
+import HieUtils
 import HieTypes
 
 supportsHieFiles :: Bool
@@ -101,10 +107,9 @@ hieExportNames = nameListFromAvails . hie_exports
 
 #else
 
+import IfaceEnv
 #if MIN_GHC_API_VERSION(8,6,0)
 import BinIface
-import Data.IORef
-import IfaceEnv
 #else
 import System.IO.Error
 #endif
@@ -113,7 +118,6 @@ import Binary
 import Control.Exception (catch)
 import Data.ByteString (ByteString)
 import GhcPlugins (Hsc, srcErrorMessages)
-import NameCache
 import TcRnTypes
 import System.IO
 import Foreign.ForeignPtr
@@ -127,6 +131,13 @@ hPutStringBuffer hdl (StringBuffer buf len cur)
 
 #endif
 
+upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
+#if !MIN_GHC_API_VERSION(8,8,0)
+upNameCache ref upd_fn
+  = atomicModifyIORef' ref upd_fn
+#else
+upNameCache = updNameCache
+#endif
 #if !MIN_GHC_API_VERSION(8,6,0)
 includePathsGlobal, includePathsQuote :: [String] -> [String]
 includePathsGlobal = id
@@ -288,7 +299,7 @@ instance Binary HieFile where
 data HieFileResult = HieFileResult { hie_file_result :: HieFile }
 
 writeHieFile :: FilePath -> HieFile -> IO ()
-readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
+readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult
 supportsHieFiles :: Bool
 
 #if MIN_GHC_API_VERSION(8,6,0)
@@ -300,9 +311,8 @@ writeHieFile fp hie = do
 
 readHieFile nc fp = do
   bh <- readBinMem fp
-  nc' <- newIORef nc
-  hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh
-  return (HieFileResult hie_file, ())
+  hie_file <- getWithUserData nc bh
+  return (HieFileResult hie_file)
 
 supportsHieFiles = True
 

test/exe/Main.hs

@@ -1548,6 +1548,15 @@ findDefinitionAndHoverTests :: TestTree
 findDefinitionAndHoverTests = let
 
   tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
+
+    -- Dirty the cache to check that definitions work even in the presence of iface files
+    liftIO $ runInDir dir $ do
+      let fooPath = dir </> "Foo.hs"
+      fooSource <- liftIO $ readFileUtf8 fooPath
+      fooDoc <- createDoc fooPath "haskell" fooSource
+      _ <- getHover fooDoc $ Position 4 3
+      closeDoc fooDoc
+
     doc <- openTestDataDoc (dir </> sourceFilePath)
     found <- get doc pos
     check found targetRange