module GHC.Iface.Binary (
writeBinIface,
readBinIface,
readBinIface_,
getSymtabName,
getDictFastString,
CheckHiWay(..),
TraceBinIFaceReading(..),
getWithUserData,
putWithUserData,
getSymbolTable,
putName,
putDictionary,
putFastString,
putSymbolTable,
BinSymbolTable(..),
BinDictionary(..)
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName )
import GHC.Iface.Env
import GHC.Driver.Types
import GHC.Unit
import GHC.Types.Name
import GHC.Driver.Session
import GHC.Driver.Ways
import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Utils.Panic
import GHC.Utils.Binary as Binary
import GHC.Types.SrcLoc
import GHC.Utils.Error
import GHC.Data.FastMutInt
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Types.Name.Cache
import GHC.Platform
import GHC.Data.FastString
import GHC.Settings.Constants
import GHC.Utils.Misc
import Data.Set (Set)
import Data.Array
import Data.Array.ST
import Data.Array.Unsafe
import Data.Bits
import Data.Char
import Data.Word
import Data.IORef
import Data.Foldable
import Control.Monad
import Control.Monad.ST
import Control.Monad.Trans.Class
import qualified Control.Monad.Trans.State.Strict as State
data CheckHiWay = CheckHiWay | IgnoreHiWay
deriving Eq
data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
deriving Eq
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
-> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do
ncu <- mkNameCacheUpdater
dflags <- getDynFlags
liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
-> NameCacheUpdater
-> IO ModIface
readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
let platform = targetPlatform dflags
printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd ->
putLogMsg dflags
NoReason
SevOutput
noSrcSpan
$ withPprStyle defaultDumpStyle sd
QuietBinIFaceReading -> \_ -> return ()
wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot what wanted got ppr' =
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_way <- get bh
let way_descr = getWayDescr platform (ways dflags)
wantedGot "Way" way_descr check_way ppr
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
extFields_p <- get bh
mod_iface <- getWithUserData ncu bh
seekBin bh extFields_p
extFields <- get bh
return mod_iface{mi_ext_fields = extFields}
getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData ncu 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 ncu
seekBin bh data_p
return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
(getDictFastString dict)
get bh
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
writeBinIface dflags hi_path mod_iface = do
bh <- openBinMem initBinMemSize
let platform = targetPlatform dflags
put_ bh (binaryInterfaceMagic platform)
put_ bh (show hiVersion)
let way_descr = getWayDescr platform (ways dflags)
put_ bh way_descr
extFields_p_p <- tellBin bh
put_ bh extFields_p_p
putWithUserData (debugTraceMsg dflags 3) 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 => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
putWithUserData log_action 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
writeFastMutInt symtab_next 0
symtab_map <- newIORef emptyUFM
let bin_symtab = BinSymbolTable {
bin_symtab_next = symtab_next,
bin_symtab_map = symtab_map }
dict_next_ref <- newFastMutInt
writeFastMutInt dict_next_ref 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
log_action (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
log_action (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 -> NameCacheUpdater -> IO SymbolTable
getSymbolTable bh ncu = do
sz <- get bh
od_names <- sequence (replicate sz (get bh))
updateNameCache ncu $ \namecache ->
runST $ flip State.evalStateT namecache $ do
mut_arr <- lift $ newSTArray_ (0, sz1)
for_ (zip [0..] od_names) $ \(i, odn) -> do
(nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
lift $ writeArray mut_arr i n
State.put nc
arr <- lift $ unsafeFreeze mut_arr
namecache' <- State.get
return (namecache', arr)
where
newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
newSTArray_ = newArray_
type OnDiskName = (Unit, ModuleName, OccName)
fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName nc (pid, mod_name, occ) =
let mod = mkModule pid mod_name
cache = nsNames nc
in case lookupOrigNameCache cache mod occ of
Just name -> (nc, name)
Nothing ->
let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
name = mkExternalName uniq mod occ noSrcSpan
new_cache = extendNameCache cache mod occ name
in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName bh name _ = do
let mod = ASSERT2( 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 :: NameCacheUpdater
-> Dictionary -> SymbolTable
-> BinHandle -> IO Name
getSymtabName _ncu _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)))
}
getWayDescr :: Platform -> Set Way -> String
getWayDescr platform ws
| platformUnregisterised platform = 'u':tag
| otherwise = tag
where tag = waysBuildTag ws