module GHC.Iface.Binary (
writeBinIface,
readBinIface,
readBinIfaceHeader,
getSymtabName,
getDictFastString,
CheckHiWay(..),
TraceBinIFace(..),
getWithUserData,
putWithUserData,
getSymbolTable,
putName,
putDictionary,
putFastString,
putSymbolTable,
BinSymbolTable(..),
BinDictionary(..)
) where
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName )
import GHC.Unit
import GHC.Unit.Module.ModIface
import GHC.Types.Name
import GHC.Platform.Profile
import GHC.Types.Unique.FM
import GHC.Utils.Panic
import GHC.Utils.Binary as Binary
import GHC.Data.FastMutInt
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Types.Name.Cache
import GHC.Types.SrcLoc
import GHC.Platform
import GHC.Data.FastString
import GHC.Settings.Constants
import GHC.Utils.Fingerprint
import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
import Data.Char
import Data.Word
import Data.IORef
import Control.Monad
data CheckHiWay = CheckHiWay | IgnoreHiWay
deriving Eq
data TraceBinIFace
= TraceBinIFace (SDoc -> IO ())
| QuietBinIFace
readBinIfaceHeader
:: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> FilePath
-> IO (Fingerprint, BinHandle)
readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
let platform = profilePlatform profile
wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot what wanted got ppr' =
case traceBinIFace of
QuietBinIFace -> return ()
TraceBinIFace printer -> printer $
text what <> text ": " <>
vcat [text "Wanted " <> ppr' wanted <> text ",",
text "got " <> ppr' got]
errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch what wanted got =
when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
(what ++ " (wanted " ++ show wanted
++ ", got " ++ show got ++ ")")
bh <- Binary.readBinMem hi_path
magic <- get bh
wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength)
errorOnMismatch "magic number mismatch: old/corrupt interface file?"
(unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic)
check_ver <- get bh
let our_ver = show hiVersion
wantedGot "Version" our_ver check_ver text
errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_tag <- get bh
let tag = profileBuildTag profile
wantedGot "Way" tag check_tag ppr
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file profile tag" tag check_tag
src_hash <- get bh
pure (src_hash, bh)
readBinIface
:: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> FilePath
-> IO ModIface
readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
(src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path
extFields_p <- get bh
mod_iface <- getWithUserData name_cache bh
seekBin bh extFields_p
extFields <- get bh
return mod_iface
{ mi_ext_fields = extFields
, mi_src_hash = src_hash
}
getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
getWithUserData name_cache bh = do
dict_p <- Binary.get bh
data_p <- tellBin bh
seekBin bh dict_p
dict <- getDictionary bh
seekBin bh data_p
bh <- do
bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
(getDictFastString dict)
symtab_p <- Binary.get bh
data_p <- tellBin bh
seekBin bh symtab_p
symtab <- getSymbolTable bh name_cache
seekBin bh data_p
return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
(getDictFastString dict)
get bh
writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
writeBinIface profile traceBinIface hi_path mod_iface = do
bh <- openBinMem initBinMemSize
let platform = profilePlatform profile
put_ bh (binaryInterfaceMagic platform)
put_ bh (show hiVersion)
let tag = profileBuildTag profile
put_ bh tag
put_ bh (mi_src_hash mod_iface)
extFields_p_p <- tellBin bh
put_ bh extFields_p_p
putWithUserData traceBinIface bh mod_iface
extFields_p <- tellBin bh
putAt bh extFields_p_p extFields_p
seekBin bh extFields_p
put_ bh (mi_ext_fields mod_iface)
writeBinMem bh hi_path
putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData traceBinIface bh payload = do
dict_p_p <- tellBin bh
put_ bh dict_p_p
symtab_p_p <- tellBin bh
put_ bh symtab_p_p
symtab_next <- newFastMutInt 0
symtab_map <- newIORef emptyUFM
let bin_symtab = BinSymbolTable {
bin_symtab_next = symtab_next,
bin_symtab_map = symtab_map }
dict_next_ref <- newFastMutInt 0
dict_map_ref <- newIORef emptyUFM
let bin_dict = BinDictionary {
bin_dict_next = dict_next_ref,
bin_dict_map = dict_map_ref }
bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
(putName bin_dict bin_symtab)
(putFastString bin_dict)
put_ bh payload
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
case traceBinIface of
QuietBinIFace -> return ()
TraceBinIFace printer ->
printer (text "writeBinIface:" <+> int symtab_next
<+> text "Names")
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
case traceBinIface of
QuietBinIFace -> return ()
TraceBinIFace printer ->
printer (text "writeBinIface:" <+> int dict_next
<+> text "dict entries")
initBinMemSize :: Int
initBinMemSize = 1024 * 1024
binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic platform
| target32Bit platform = FixedLengthEncoding 0x1face
| otherwise = FixedLengthEncoding 0x1face64
putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = elems (array (0,next_off1) (nonDetEltsUFM symtab))
mapM_ (\n -> serialiseName bh n symtab) names
getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable bh name_cache = do
sz <- get bh :: IO Int
updateNameCache' name_cache $ \cache0 -> do
mut_arr <- newArray_ (0, sz1) :: IO (IOArray Int Name)
cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do
let mod = mkModule uid mod_name
case lookupOrigNameCache cache mod occ of
Just name -> do
writeArray mut_arr (fromIntegral i) name
return cache
Nothing -> do
uniq <- takeUniqFromNameCache name_cache
let name = mkExternalName uniq mod occ noSrcSpan
new_cache = extendOrigNameCache cache mod occ name
writeArray mut_arr (fromIntegral i) name
return new_cache
arr <- unsafeFreeze mut_arr
return (cache, arr)
serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName bh name _ = do
let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName _dict BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next }
bh name
| isKnownKeyName name
, let (c, u) = unpkUnique (nameUnique name)
=
put_ bh (0x80000000
.|. (fromIntegral (ord c) `shiftL` 22)
.|. (fromIntegral u :: Word32))
| otherwise
= do symtab_map <- readIORef symtab_map_ref
case lookupUFM symtab_map name of
Just (off,_) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
off <- readFastMutInt symtab_next
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
put_ bh (fromIntegral off :: Word32)
getSymtabName :: NameCache
-> Dictionary -> SymbolTable
-> BinHandle -> IO Name
getSymtabName _name_cache _dict symtab bh = do
i :: Word32 <- get bh
case i .&. 0xC0000000 of
0x00000000 -> return $! symtab ! fromIntegral i
0x80000000 ->
let
tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
ix = fromIntegral i .&. 0x003FFFFF
u = mkUnique tag ix
in
return $! case lookupKnownKeyName u of
Nothing -> pprPanic "getSymtabName:unknown known-key unique"
(ppr i $$ ppr (unpkUnique u))
Just n -> n
_ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
data BinSymbolTable = BinSymbolTable {
bin_symtab_next :: !FastMutInt,
bin_symtab_map :: !(IORef (UniqFM Name (Int,Name)))
}
putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary { bin_dict_next = j_r,
bin_dict_map = out_r} f = do
out <- readIORef out_r
let !uniq = getUnique f
case lookupUFM_Directly out uniq of
Just (j, _) -> return (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM_Directly out uniq (j, f)
return (fromIntegral j :: Word32)
getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString dict bh = do
j <- get bh
return $! (dict ! fromIntegral (j :: Word32))
data BinDictionary = BinDictionary {
bin_dict_next :: !FastMutInt,
bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString)))
}