module BinIface (
writeBinIface,
readBinIface,
getSymtabName,
getDictFastString,
CheckHiWay(..),
TraceBinIFaceReading(..),
getWithUserData,
putWithUserData,
getSymbolTable,
putName,
putDictionary,
putFastString,
putSymbolTable,
BinSymbolTable(..),
BinDictionary(..)
) where
#include "HsVersions.h"
import GhcPrelude
import TcRnMonad
import PrelInfo ( isKnownKeyName, lookupKnownKeyName )
import IfaceEnv
import HscTypes
import Module
import Name
import DynFlags
import UniqFM
import UniqSupply
import Panic
import Binary
import SrcLoc
import ErrUtils
import FastMutInt
import Unique
import Outputable
import NameCache
import GHC.Platform
import FastString
import Constants
import Util
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 printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd ->
putLogMsg dflags
NoReason
SevOutput
noSrcSpan
(defaultDumpStyle dflags)
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 dflags) magic ppr
errorOnMismatch "magic number mismatch: old/corrupt interface file?"
(binaryInterfaceMagic dflags) magic
if wORD_SIZE dflags == 4
then do _ <- Binary.get bh :: IO Word32; return ()
else do _ <- Binary.get bh :: IO Word64; return ()
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 dflags
wantedGot "Way" way_descr check_way ppr
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
getWithUserData ncu bh
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
put_ bh (binaryInterfaceMagic dflags)
if wORD_SIZE dflags == 4
then Binary.put_ bh (0 :: Word32)
else Binary.put_ bh (0 :: Word64)
put_ bh (show hiVersion)
let way_descr = getWayDescr dflags
put_ bh way_descr
putWithUserData (debugTraceMsg dflags 3) bh 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 :: DynFlags -> Word32
binaryInterfaceMagic dflags
| target32Bit (targetPlatform dflags) = 0x1face
| otherwise = 0x1face64
putSymbolTable :: BinHandle -> Int -> UniqFM (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 = (UnitId, 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 (Int,Name) -> IO ()
serialiseName bh name _ = do
let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
put_ bh (moduleUnitId 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 (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 out uniq of
Just (j, _) -> return (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM 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 (Int,FastString)))
}
getWayDescr :: DynFlags -> String
getWayDescr dflags
| platformUnregisterised (targetPlatform dflags) = 'u':tag
| otherwise = tag
where tag = buildTag dflags