module GHC.Iface.Ext.Binary
( readHieFile
, readHieFileWithVersion
, HieHeader
, writeHieFile
, HieName(..)
, toHieName
, HieFileResult(..)
, hieMagic
, hieNameOcc
)
where
import GHC.Settings.Utils ( maybeRead )
import GHC.Settings.Config ( cProjectVersion )
import GHC.Prelude
import GHC.Utils.Binary
import GHC.Data.FastMutInt
import GHC.Data.FastString ( FastString )
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Builtin.Utils
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.FM
import qualified Data.Array as A
import qualified Data.Array.IO as A
import qualified Data.Array.Unsafe as A
import Data.IORef
import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Word ( Word8, Word32 )
import Control.Monad ( replicateM, when, forM_ )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath ( takeDirectory )
import GHC.Iface.Ext.Types
data HieSymbolTable = HieSymbolTable
{ HieSymbolTable -> FastMutInt
hie_symtab_next :: !FastMutInt
, HieSymbolTable -> IORef (UniqFM Name (Int, HieName))
hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName)))
}
data HieDictionary = HieDictionary
{ HieDictionary -> FastMutInt
hie_dict_next :: !FastMutInt
, HieDictionary -> IORef (UniqFM FastString (Int, FastString))
hie_dict_map :: !(IORef (UniqFM FastString (Int,FastString)))
}
initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = Int
1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024
hieMagic :: [Word8]
hieMagic :: [Word8]
hieMagic = [Word8
72,Word8
73,Word8
69]
hieMagicLen :: Int
hieMagicLen :: Int
hieMagicLen = [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
hieMagic
ghcVersion :: ByteString
ghcVersion :: ByteString
ghcVersion = [Char] -> ByteString
BSC.pack [Char]
cProjectVersion
putBinLine :: BinHandle -> ByteString -> IO ()
putBinLine :: BinHandle -> ByteString -> IO ()
putBinLine BinHandle
bh ByteString
xs = do
(Word8 -> IO ()) -> [Word8] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> Word8 -> IO ()
putByte BinHandle
bh) ([Word8] -> IO ()) -> [Word8] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
xs
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
10
writeHieFile :: FilePath -> HieFile -> IO ()
writeHieFile :: [Char] -> HieFile -> IO ()
writeHieFile [Char]
hie_file_path HieFile
hiefile = do
bh0 <- Int -> IO BinHandle
openBinMem Int
initBinMemSize
mapM_ (putByte bh0) hieMagic
putBinLine bh0 $ BSC.pack $ show hieVersion
putBinLine bh0 $ ghcVersion
dict_p_p <- tellBin bh0
put_ bh0 dict_p_p
symtab_p_p <- tellBin bh0
put_ bh0 symtab_p_p
symtab_next <- newFastMutInt 0
symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))
let hie_symtab = HieSymbolTable {
hie_symtab_next :: FastMutInt
hie_symtab_next = FastMutInt
symtab_next,
hie_symtab_map :: IORef (UniqFM Name (Int, HieName))
hie_symtab_map = IORef (UniqFM Name (Int, HieName))
symtab_map }
dict_next_ref <- newFastMutInt 0
dict_map_ref <- newIORef emptyUFM
let hie_dict = HieDictionary {
hie_dict_next :: FastMutInt
hie_dict_next = FastMutInt
dict_next_ref,
hie_dict_map :: IORef (UniqFM FastString (Int, FastString))
hie_dict_map = IORef (UniqFM FastString (Int, FastString))
dict_map_ref }
let bh = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh0 (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
newWriteState (HieSymbolTable -> BinHandle -> Name -> IO ()
putName HieSymbolTable
hie_symtab)
(HieSymbolTable -> BinHandle -> Name -> IO ()
putName HieSymbolTable
hie_symtab)
(HieDictionary -> BinHandle -> FastString -> IO ()
putFastString HieDictionary
hie_dict)
put_ bh hiefile
symtab_p <- tellBin bh
putAt bh symtab_p_p symtab_p
seekBin bh symtab_p
symtab_next' <- readFastMutInt symtab_next
symtab_map' <- readIORef symtab_map
putSymbolTable bh symtab_next' symtab_map'
dict_p <- tellBin bh
putAt bh dict_p_p dict_p
seekBin bh dict_p
dict_next <- readFastMutInt dict_next_ref
dict_map <- readIORef dict_map_ref
putDictionary bh dict_next dict_map
createDirectoryIfMissing True (takeDirectory hie_file_path)
writeBinMem bh hie_file_path
return ()
data HieFileResult
= HieFileResult
{ HieFileResult -> Integer
hie_file_result_version :: Integer
, HieFileResult -> ByteString
hie_file_result_ghc_version :: ByteString
, HieFileResult -> HieFile
hie_file_result :: HieFile
}
type = (Integer, ByteString)
readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader HieFileResult)
readHieFileWithVersion :: (HieHeader -> Bool)
-> NameCache -> [Char] -> IO (Either HieHeader HieFileResult)
readHieFileWithVersion HieHeader -> Bool
readVersion NameCache
name_cache [Char]
file = do
bh0 <- [Char] -> IO BinHandle
readBinMem [Char]
file
(hieVersion, ghcVersion) <- readHieFileHeader file bh0
if readVersion (hieVersion, ghcVersion)
then do
hieFile <- readHieFileContents bh0 name_cache
return $ Right (HieFileResult hieVersion ghcVersion hieFile)
else return $ Left (hieVersion, ghcVersion)
readHieFile :: NameCache -> FilePath -> IO HieFileResult
readHieFile :: NameCache -> [Char] -> IO HieFileResult
readHieFile NameCache
name_cache [Char]
file = do
bh0 <- [Char] -> IO BinHandle
readBinMem [Char]
file
(readHieVersion, ghcVersion) <- readHieFileHeader file bh0
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 name_cache
return $ HieFileResult hieVersion ghcVersion hieFile
readBinLine :: BinHandle -> IO ByteString
readBinLine :: BinHandle -> IO ByteString
readBinLine BinHandle
bh = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> ([Word8] -> [Word8]) -> [Word8] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8]
forall a. [a] -> [a]
reverse ([Word8] -> ByteString) -> IO [Word8] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word8] -> IO [Word8]
loop []
where
loop :: [Word8] -> IO [Word8]
loop [Word8]
acc = do
char <- BinHandle -> IO Word8
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Word8
if char == 10
then return acc
else loop (char : acc)
readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
[Char]
file BinHandle
bh0 = do
magic <- Int -> IO Word8 -> IO [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
hieMagicLen (BinHandle -> IO Word8
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh0)
version <- BSC.unpack <$> readBinLine bh0
case maybeRead version of
Maybe Integer
Nothing ->
[Char] -> IO HieHeader
forall a. HasCallStack => [Char] -> a
panic ([Char] -> IO HieHeader) -> [Char] -> IO HieHeader
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"readHieFileHeader: hieVersion isn't an Integer:"
, [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
version
]
Just Integer
readHieVersion -> do
ghcVersion <- BinHandle -> IO ByteString
readBinLine BinHandle
bh0
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 -> NameCache -> IO HieFile
readHieFileContents :: BinHandle -> NameCache -> IO HieFile
readHieFileContents BinHandle
bh0 NameCache
name_cache = do
dict <- BinHandle -> IO Dictionary
get_dictionary BinHandle
bh0
bh1 <- do
let bh1 = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh0 (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState ([Char] -> BinHandle -> IO Name
forall a. HasCallStack => [Char] -> a
error [Char]
"getSymtabName")
(Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
symtab <- get_symbol_table bh1
let bh1' = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh1
(UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (SymbolTable -> BinHandle -> IO Name
getSymTabName SymbolTable
symtab)
(Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
return bh1'
get bh1
where
get_dictionary :: BinHandle -> IO Dictionary
get_dictionary BinHandle
bin_handle = do
dict_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
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 :: BinHandle -> IO SymbolTable
get_symbol_table BinHandle
bh1 = do
symtab_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh1
data_p' <- tellBin bh1
seekBin bh1 symtab_p
symtab <- getSymbolTable bh1 name_cache
seekBin bh1 data_p'
return symtab
putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next :: HieDictionary -> FastMutInt
hie_dict_next = FastMutInt
j_r,
hie_dict_map :: HieDictionary -> IORef (UniqFM FastString (Int, FastString))
hie_dict_map = IORef (UniqFM FastString (Int, FastString))
out_r} BinHandle
bh FastString
f
= do
out <- IORef (UniqFM FastString (Int, FastString))
-> IO (UniqFM FastString (Int, FastString))
forall a. IORef a -> IO a
readIORef IORef (UniqFM FastString (Int, FastString))
out_r
let !unique = FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
f
case lookupUFM_Directly out unique of
Just (Int
j, FastString
_) -> BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j :: Word32)
Maybe (Int, FastString)
Nothing -> do
j <- FastMutInt -> IO Int
readFastMutInt FastMutInt
j_r
put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM_Directly out unique (j, f)
putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int, HieName) -> IO ()
putSymbolTable BinHandle
bh Int
next_off UniqFM Name (Int, HieName)
symtab = do
BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
next_off
let names :: [HieName]
names = Array Int HieName -> [HieName]
forall i e. Array i e -> [e]
A.elems ((Int, Int) -> [(Int, HieName)] -> Array Int HieName
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
A.array (Int
0,Int
next_offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (UniqFM Name (Int, HieName) -> [(Int, HieName)]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM Name (Int, HieName)
symtab))
(HieName -> IO ()) -> [HieName] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> HieName -> IO ()
putHieName BinHandle
bh) [HieName]
names
getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable BinHandle
bh NameCache
name_cache = do
sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)
forM_ [0..(sz-1)] $ \Int
i -> do
od_name <- BinHandle -> IO HieName
getHieName BinHandle
bh
name <- fromHieName name_cache od_name
A.writeArray mut_arr i name
A.unsafeFreeze mut_arr
getSymTabName :: SymbolTable -> BinHandle -> IO Name
getSymTabName :: SymbolTable -> BinHandle -> IO Name
getSymTabName SymbolTable
st BinHandle
bh = do
i :: Word32 <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
return $ st A.! (fromIntegral i)
putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
putName (HieSymbolTable FastMutInt
next IORef (UniqFM Name (Int, HieName))
ref) BinHandle
bh Name
name = do
symmap <- IORef (UniqFM Name (Int, HieName))
-> IO (UniqFM Name (Int, HieName))
forall a. IORef a -> IO a
readIORef IORef (UniqFM Name (Int, HieName))
ref
case lookupUFM symmap name of
Just (Int
off, ExternalName Module
mod OccName
occ (UnhelpfulSpan UnhelpfulSpanReason
_))
| SrcSpan -> Bool
isGoodSrcSpan (Name -> SrcSpan
nameSrcSpan Name
name) -> do
let hieName :: HieName
hieName = Module -> OccName -> SrcSpan -> HieName
ExternalName Module
mod OccName
occ (Name -> SrcSpan
nameSrcSpan Name
name)
IORef (UniqFM Name (Int, HieName))
-> UniqFM Name (Int, HieName) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM Name (Int, HieName))
ref (UniqFM Name (Int, HieName) -> IO ())
-> UniqFM Name (Int, HieName) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM Name (Int, HieName)
-> Name -> (Int, HieName) -> UniqFM Name (Int, HieName)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Name (Int, HieName)
symmap Name
name (Int
off, HieName
hieName)
BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
Just (Int
off, LocalName OccName
_occ SrcSpan
span)
| HieName -> Bool
notLocal (Name -> HieName
toHieName Name
name) Bool -> Bool -> Bool
|| Name -> SrcSpan
nameSrcSpan Name
name SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
/= SrcSpan
span -> do
IORef (UniqFM Name (Int, HieName))
-> UniqFM Name (Int, HieName) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM Name (Int, HieName))
ref (UniqFM Name (Int, HieName) -> IO ())
-> UniqFM Name (Int, HieName) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM Name (Int, HieName)
-> Name -> (Int, HieName) -> UniqFM Name (Int, HieName)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Name (Int, HieName)
symmap Name
name (Int
off, Name -> HieName
toHieName Name
name)
BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
Just (Int
off, HieName
_) -> BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
Maybe (Int, HieName)
Nothing -> do
off <- FastMutInt -> IO Int
readFastMutInt FastMutInt
next
writeFastMutInt next (off+1)
writeIORef ref $! addToUFM symmap name (off, toHieName name)
put_ bh (fromIntegral off :: Word32)
where
notLocal :: HieName -> Bool
notLocal :: HieName -> Bool
notLocal LocalName{} = Bool
False
notLocal HieName
_ = Bool
True
fromHieName :: NameCache -> HieName -> IO Name
fromHieName :: NameCache -> HieName -> IO Name
fromHieName NameCache
nc HieName
hie_name = do
case HieName
hie_name of
ExternalName Module
mod OccName
occ SrcSpan
span -> NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, Name))
-> IO Name
forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache NameCache
nc Module
mod OccName
occ ((OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name)
-> (OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name
forall a b. (a -> b) -> a -> b
$ \OrigNameCache
cache -> do
case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache Module
mod OccName
occ of
Just Name
name -> (OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache, Name
name)
Maybe Name
Nothing -> do
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
nc
let name = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
span
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache Module
mod OccName
occ Name
name
pure (new_cache, name)
LocalName OccName
occ SrcSpan
span -> do
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
nc
pure $ mkInternalName uniq occ span
KnownKeyName Unique
u -> case Unique -> Maybe Name
lookupKnownKeyName Unique
u of
Maybe Name
Nothing -> [Char] -> SDoc -> IO Name
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"fromHieName:unknown known-key unique"
(Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u)
Just Name
n -> Name -> IO Name
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
putHieName :: BinHandle -> HieName -> IO ()
putHieName :: BinHandle -> HieName -> IO ()
putHieName BinHandle
bh (ExternalName Module
mod OccName
occ SrcSpan
span) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
BinHandle -> (Module, OccName, BinSrcSpan) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Module
mod, OccName
occ, SrcSpan -> BinSrcSpan
BinSrcSpan SrcSpan
span)
putHieName BinHandle
bh (LocalName OccName
occName SrcSpan
span) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
BinHandle -> (OccName, BinSrcSpan) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (OccName
occName, SrcSpan -> BinSrcSpan
BinSrcSpan SrcSpan
span)
putHieName BinHandle
bh (KnownKeyName Unique
uniq) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
BinHandle -> (Char, Word64) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ((Char, Word64) -> IO ()) -> (Char, Word64) -> IO ()
forall a b. (a -> b) -> a -> b
$ Unique -> (Char, Word64)
unpkUnique Unique
uniq
getHieName :: BinHandle -> IO HieName
getHieName :: BinHandle -> IO HieName
getHieName BinHandle
bh = do
t <- BinHandle -> IO Word8
getByte BinHandle
bh
case t of
Word8
0 -> do
(modu, occ, span) <- BinHandle -> IO (Module, OccName, BinSrcSpan)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
return $ ExternalName modu occ $ unBinSrcSpan span
Word8
1 -> do
(occ, span) <- BinHandle -> IO (OccName, BinSrcSpan)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
return $ LocalName occ $ unBinSrcSpan span
Word8
2 -> do
(c,i) <- BinHandle -> IO (Char, Word64)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
return $ KnownKeyName $ mkUnique c i
Word8
_ -> [Char] -> IO HieName
forall a. HasCallStack => [Char] -> a
panic [Char]
"GHC.Iface.Ext.Binary.getHieName: invalid tag"