{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-}
{-# OPTIONS_GHC -O2 #-}
module GHC.Iface.Binary (
writeBinIface,
readBinIface,
readBinIfaceHeader,
getSymtabName,
CheckHiWay(..),
TraceBinIFace(..),
getWithUserData,
putWithUserData,
getSymbolTable,
putName,
putSymbolTable,
BinSymbolTable(..),
) 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.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 CheckHiWay -> CheckHiWay -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckHiWay -> CheckHiWay -> Bool
$c/= :: CheckHiWay -> CheckHiWay -> Bool
== :: CheckHiWay -> CheckHiWay -> Bool
$c== :: CheckHiWay -> CheckHiWay -> Bool
Eq
data TraceBinIFace
= TraceBinIFace (SDoc -> IO ())
| QuietBinIFace
readBinIfaceHeader
:: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> FilePath
-> IO (Fingerprint, BinHandle)
Profile
profile NameCache
_name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIFace String
hi_path = do
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot :: forall a. String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot String
what a
wanted a
got a -> SDoc
ppr' =
case TraceBinIFace
traceBinIFace of
TraceBinIFace
QuietBinIFace -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TraceBinIFace SDoc -> IO ()
printer -> SDoc -> IO ()
printer forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
what forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
": " forall doc. IsLine doc => doc -> doc -> doc
<>
forall doc. IsDoc doc => [doc] -> doc
vcat [forall doc. IsLine doc => String -> doc
text String
"Wanted " forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
ppr' a
wanted forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
",",
forall doc. IsLine doc => String -> doc
text String
"got " forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
ppr' a
got]
errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch :: forall a. (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch String
what a
wanted a
got =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
wanted forall a. Eq a => a -> a -> Bool
/= a
got) forall a b. (a -> b) -> a -> b
$ forall a. GhcException -> IO a
throwGhcExceptionIO forall a b. (a -> b) -> a -> b
$ String -> GhcException
ProgramError
(String
what forall a. [a] -> [a] -> [a]
++ String
" (wanted " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
wanted
forall a. [a] -> [a] -> [a]
++ String
", got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
got forall a. [a] -> [a] -> [a]
++ String
")")
BinHandle
bh <- String -> IO BinHandle
Binary.readBinMem String
hi_path
FixedLengthEncoding Word32
magic <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall a. String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot String
"Magic" (Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic Platform
platform) FixedLengthEncoding Word32
magic (forall a. Outputable a => a -> SDoc
ppr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedLengthEncoding a -> a
unFixedLength)
forall a. (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch String
"magic number mismatch: old/corrupt interface file?"
(forall a. FixedLengthEncoding a -> a
unFixedLength forall a b. (a -> b) -> a -> b
$ Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic Platform
platform) (forall a. FixedLengthEncoding a -> a
unFixedLength FixedLengthEncoding Word32
magic)
String
check_ver <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
let our_ver :: String
our_ver = forall a. Show a => a -> String
show Integer
hiVersion
forall a. String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot String
"Version" String
our_ver String
check_ver forall doc. IsLine doc => String -> doc
text
forall a. (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch String
"mismatched interface file versions" String
our_ver String
check_ver
String
check_tag <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
let tag :: String
tag = Profile -> String
profileBuildTag Profile
profile
forall a. String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot String
"Way" String
tag String
check_tag forall doc. IsLine doc => String -> doc
text
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CheckHiWay
checkHiWay forall a. Eq a => a -> a -> Bool
== CheckHiWay
CheckHiWay) forall a b. (a -> b) -> a -> b
$
forall a. (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch String
"mismatched interface file profile tag" String
tag String
check_tag
Fingerprint
src_hash <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fingerprint
src_hash, BinHandle
bh)
readBinIface
:: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> FilePath
-> IO ModIface
readBinIface :: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO ModIface
readBinIface Profile
profile NameCache
name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIface String
hi_path = do
(Fingerprint
src_hash, BinHandle
bh) <- Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO (Fingerprint, BinHandle)
readBinIfaceHeader Profile
profile NameCache
name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIface String
hi_path
Bin Any
extFields_p <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
ModIface
mod_iface <- forall a. Binary a => NameCache -> BinHandle -> IO a
getWithUserData NameCache
name_cache BinHandle
bh
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
extFields_p
ExtensibleFields
extFields <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
mod_iface
{ mi_ext_fields :: ExtensibleFields
mi_ext_fields = ExtensibleFields
extFields
, mi_src_hash :: Fingerprint
mi_src_hash = Fingerprint
src_hash
}
getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
getWithUserData :: forall a. Binary a => NameCache -> BinHandle -> IO a
getWithUserData NameCache
name_cache BinHandle
bh = do
BinHandle
bh <- NameCache -> BinHandle -> IO BinHandle
getTables NameCache
name_cache BinHandle
bh
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
getTables :: NameCache -> BinHandle -> IO BinHandle
getTables :: NameCache -> BinHandle -> IO BinHandle
getTables NameCache
name_cache BinHandle
bh = do
Dictionary
dict <- forall a. BinHandle -> IO a -> IO a
Binary.forwardGet BinHandle
bh (BinHandle -> IO Dictionary
getDictionary BinHandle
bh)
let bh_fs :: BinHandle
bh_fs = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (forall a. HasCallStack => String -> a
error String
"getSymtabName")
(Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
SymbolTable
symtab <- forall a. BinHandle -> IO a -> IO a
Binary.forwardGet BinHandle
bh_fs (BinHandle -> NameCache -> IO SymbolTable
getSymbolTable BinHandle
bh_fs NameCache
name_cache)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (NameCache -> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName NameCache
name_cache Dictionary
dict SymbolTable
symtab)
(Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
writeBinIface :: Profile -> TraceBinIFace -> String -> ModIface -> IO ()
writeBinIface Profile
profile TraceBinIFace
traceBinIface String
hi_path ModIface
mod_iface = do
BinHandle
bh <- Int -> IO BinHandle
openBinMem Int
initBinMemSize
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic Platform
platform)
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a. Show a => a -> String
show Integer
hiVersion)
let tag :: String
tag = Profile -> String
profileBuildTag Profile
profile
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh String
tag
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_src_hash ModIface
mod_iface)
Bin (Bin Any)
extFields_p_p <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
extFields_p_p
forall a. Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData TraceBinIFace
traceBinIface BinHandle
bh ModIface
mod_iface
Bin Any
extFields_p <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
extFields_p_p Bin Any
extFields_p
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
extFields_p
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall (phase :: ModIfacePhase).
ModIface_ phase -> ExtensibleFields
mi_ext_fields ModIface
mod_iface)
BinHandle -> String -> IO ()
writeBinMem BinHandle
bh String
hi_path
putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData :: forall a. Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData TraceBinIFace
traceBinIface BinHandle
bh a
payload = do
(Int
name_count, Int
fs_count, Bin a
_b) <- forall b. BinHandle -> (BinHandle -> IO b) -> IO (Int, Int, b)
putWithTables BinHandle
bh (\BinHandle
bh' -> forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
bh' a
payload)
case TraceBinIFace
traceBinIface of
TraceBinIFace
QuietBinIFace -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TraceBinIFace SDoc -> IO ()
printer -> do
SDoc -> IO ()
printer (forall doc. IsLine doc => String -> doc
text String
"writeBinIface:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Int -> doc
int Int
name_count
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"Names")
SDoc -> IO ()
printer (forall doc. IsLine doc => String -> doc
text String
"writeBinIface:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Int -> doc
int Int
fs_count
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"dict entries")
putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b)
putWithTables :: forall b. BinHandle -> (BinHandle -> IO b) -> IO (Int, Int, b)
putWithTables BinHandle
bh BinHandle -> IO b
put_payload = do
FastMutInt
symtab_next <- Int -> IO FastMutInt
newFastMutInt Int
0
IORef (UniqFM Name (Int, Name))
symtab_map <- forall a. a -> IO (IORef a)
newIORef forall key elt. UniqFM key elt
emptyUFM
let bin_symtab :: BinSymbolTable
bin_symtab = BinSymbolTable
{ bin_symtab_next :: FastMutInt
bin_symtab_next = FastMutInt
symtab_next
, bin_symtab_map :: IORef (UniqFM Name (Int, Name))
bin_symtab_map = IORef (UniqFM Name (Int, Name))
symtab_map
}
(BinHandle
bh_fs, FSTable
bin_dict, IO Int
put_dict) <- BinHandle -> IO (BinHandle, FSTable, IO Int)
initFSTable BinHandle
bh
(Int
fs_count,(Int
name_count,b
r)) <- forall b a. BinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPut BinHandle
bh (forall a b. a -> b -> a
const IO Int
put_dict) forall a b. (a -> b) -> a -> b
$ do
let put_symtab :: IO Int
put_symtab = do
Int
name_count <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
UniqFM Name (Int, Name)
symtab_map <- forall a. IORef a -> IO a
readIORef IORef (UniqFM Name (Int, Name))
symtab_map
BinHandle -> Int -> UniqFM Name (Int, Name) -> IO ()
putSymbolTable BinHandle
bh_fs Int
name_count UniqFM Name (Int, Name)
symtab_map
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
name_count
forall b a. BinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPut BinHandle
bh_fs (forall a b. a -> b -> a
const IO Int
put_symtab) forall a b. (a -> b) -> a -> b
$ do
let ud_fs :: UserData
ud_fs = BinHandle -> UserData
getUserData BinHandle
bh_fs
let ud_name :: UserData
ud_name = UserData
ud_fs
{ ud_put_nonbinding_name :: BinHandle -> Name -> IO ()
ud_put_nonbinding_name = FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName FSTable
bin_dict BinSymbolTable
bin_symtab
, ud_put_binding_name :: BinHandle -> Name -> IO ()
ud_put_binding_name = FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName FSTable
bin_dict BinSymbolTable
bin_symtab
}
let bh_name :: BinHandle
bh_name = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh UserData
ud_name
BinHandle -> IO b
put_payload BinHandle
bh_name
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
name_count, Int
fs_count, b
r)
initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = Int
1024 forall a. Num a => a -> a -> a
* Int
1024
binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic Platform
platform
| Platform -> Bool
target32Bit Platform
platform = forall a. a -> FixedLengthEncoding a
FixedLengthEncoding Word32
0x1face
| Bool
otherwise = forall a. a -> FixedLengthEncoding a
FixedLengthEncoding Word32
0x1face64
putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int, Name) -> IO ()
putSymbolTable BinHandle
bh Int
name_count UniqFM Name (Int, Name)
symtab = do
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
name_count
let names :: [Name]
names = forall i e. Array i e -> [e]
elems (forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,Int
name_countforall a. Num a => a -> a -> a
-Int
1) (forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM Name (Int, Name)
symtab))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> forall key. BinHandle -> Name -> UniqFM key (Int, Name) -> IO ()
serialiseName BinHandle
bh Name
n UniqFM Name (Int, Name)
symtab) [Name]
names
getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable BinHandle
bh NameCache
name_cache = do
Int
sz <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
forall c.
NameCache -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
updateNameCache' NameCache
name_cache forall a b. (a -> b) -> a -> b
$ \OrigNameCache
cache0 -> do
IOArray Int Name
mut_arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
0, Int
szforall a. Num a => a -> a -> a
-Int
1) :: IO (IOArray Int Name)
OrigNameCache
cache <- forall a b.
Binary a =>
Word -> BinHandle -> b -> (Word -> a -> b -> IO b) -> IO b
foldGet (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) BinHandle
bh OrigNameCache
cache0 forall a b. (a -> b) -> a -> b
$ \Word
i (Unit
uid, ModuleName
mod_name, OccName
occ) OrigNameCache
cache -> do
let mod :: GenModule Unit
mod = forall u. u -> ModuleName -> GenModule u
mkModule Unit
uid ModuleName
mod_name
case OrigNameCache -> GenModule Unit -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache GenModule Unit
mod OccName
occ of
Just Name
name -> do
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Int Name
mut_arr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i) Name
name
forall (m :: * -> *) a. Monad m => a -> m a
return OrigNameCache
cache
Maybe Name
Nothing -> do
Unique
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
name_cache
let name :: Name
name = Unique -> GenModule Unit -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq GenModule Unit
mod OccName
occ SrcSpan
noSrcSpan
new_cache :: OrigNameCache
new_cache = OrigNameCache -> GenModule Unit -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache GenModule Unit
mod OccName
occ Name
name
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Int Name
mut_arr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i) Name
name
forall (m :: * -> *) a. Monad m => a -> m a
return OrigNameCache
new_cache
SymbolTable
arr <- forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze IOArray Int Name
mut_arr
forall (m :: * -> *) a. Monad m => a -> m a
return (OrigNameCache
cache, SymbolTable
arr)
serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName :: forall key. BinHandle -> Name -> UniqFM key (Int, Name) -> IO ()
serialiseName BinHandle
bh Name
name UniqFM key (Int, Name)
_ = do
let mod :: GenModule Unit
mod = forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isExternalName Name
name) (forall a. Outputable a => a -> SDoc
ppr Name
name) (HasDebugCallStack => Name -> GenModule Unit
nameModule Name
name)
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall unit. GenModule unit -> unit
moduleUnit GenModule Unit
mod, forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
mod, Name -> OccName
nameOccName Name
name)
putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName FSTable
_dict BinSymbolTable{
bin_symtab_map :: BinSymbolTable -> IORef (UniqFM Name (Int, Name))
bin_symtab_map = IORef (UniqFM Name (Int, Name))
symtab_map_ref,
bin_symtab_next :: BinSymbolTable -> FastMutInt
bin_symtab_next = FastMutInt
symtab_next }
BinHandle
bh Name
name
| Name -> Bool
isKnownKeyName Name
name
, let (Char
c, Int
u) = Unique -> (Char, Int)
unpkUnique (Name -> Unique
nameUnique Name
name)
=
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Word32
0x80000000
forall a. Bits a => a -> a -> a
.|. (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) forall a. Bits a => a -> Int -> a
`shiftL` Int
22)
forall a. Bits a => a -> a -> a
.|. (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u :: Word32))
| Bool
otherwise
= do UniqFM Name (Int, Name)
symtab_map <- forall a. IORef a -> IO a
readIORef IORef (UniqFM Name (Int, Name))
symtab_map_ref
case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM Name (Int, Name)
symtab_map Name
name of
Just (Int
off,Name
_) -> forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
Maybe (Int, Name)
Nothing -> do
Int
off <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
symtab_next (Int
offforall a. Num a => a -> a -> a
+Int
1)
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM Name (Int, Name))
symtab_map_ref
forall a b. (a -> b) -> a -> b
$! forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Name (Int, Name)
symtab_map Name
name (Int
off,Name
name)
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
getSymtabName :: NameCache
-> Dictionary -> SymbolTable
-> BinHandle -> IO Name
getSymtabName :: NameCache -> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName NameCache
_name_cache Dictionary
_dict SymbolTable
symtab BinHandle
bh = do
Word32
i :: Word32 <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
case Word32
i forall a. Bits a => a -> a -> a
.&. Word32
0xC0000000 of
Word32
0x00000000 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! SymbolTable
symtab forall i e. Ix i => Array i e -> i -> e
! forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i
Word32
0x80000000 ->
let
tag :: Char
tag = Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
i forall a. Bits a => a -> a -> a
.&. Word32
0x3FC00000) forall a. Bits a => a -> Int -> a
`shiftR` Int
22))
ix :: Int
ix = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i forall a. Bits a => a -> a -> a
.&. Int
0x003FFFFF
u :: Unique
u = Char -> Int -> Unique
mkUnique Char
tag Int
ix
in
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case Unique -> Maybe Name
lookupKnownKeyName Unique
u of
Maybe Name
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSymtabName:unknown known-key unique"
(forall a. Outputable a => a -> SDoc
ppr Word32
i forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr Unique
u forall doc. IsDoc doc => doc -> doc -> doc
$$ forall doc. IsLine doc => Char -> doc
char Char
tag forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr Int
ix)
Just Name
n -> Name
n
Word32
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSymtabName:unknown name tag" (forall a. Outputable a => a -> SDoc
ppr Word32
i)
data BinSymbolTable = BinSymbolTable {
BinSymbolTable -> FastMutInt
bin_symtab_next :: !FastMutInt,
BinSymbolTable -> IORef (UniqFM Name (Int, Name))
bin_symtab_map :: !(IORef (UniqFM Name (Int,Name)))
}