{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}
{-# OPTIONS_GHC -O2 #-}
module GHC.Iface.Binary (
writeBinIface,
readBinIface,
readBinIface_,
getSymtabName,
getDictFastString,
CheckHiWay(..),
TraceBinIFace(..),
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.Unit
import GHC.Unit.Module.ModIface
import GHC.Types.Name
import GHC.Driver.Session
import GHC.Platform.Profile
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.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.Array
import Data.Array.ST
import Data.Array.Unsafe
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 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
readBinIface :: CheckHiWay -> TraceBinIFace -> FilePath
-> TcRnIf a b ModIface
readBinIface :: forall a b.
CheckHiWay -> TraceBinIFace -> String -> TcRnIf a b ModIface
readBinIface CheckHiWay
checkHiWay TraceBinIFace
traceBinIFaceReading String
hi_path = do
NameCacheUpdater
ncu <- forall a b. TcRnIf a b NameCacheUpdater
mkNameCacheUpdater
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Profile
-> CheckHiWay
-> TraceBinIFace
-> String
-> NameCacheUpdater
-> IO ModIface
readBinIface_ Profile
profile CheckHiWay
checkHiWay TraceBinIFace
traceBinIFaceReading String
hi_path NameCacheUpdater
ncu
readBinIface_ :: Profile -> CheckHiWay -> TraceBinIFace -> FilePath
-> NameCacheUpdater
-> IO ModIface
readBinIface_ :: Profile
-> CheckHiWay
-> TraceBinIFace
-> String
-> NameCacheUpdater
-> IO ModIface
readBinIface_ Profile
profile CheckHiWay
checkHiWay TraceBinIFace
traceBinIFace String
hi_path NameCacheUpdater
ncu = 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
$
String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
": " SDoc -> SDoc -> SDoc
<>
[SDoc] -> SDoc
vcat [String -> SDoc
text String
"Wanted " SDoc -> SDoc -> SDoc
<> a -> SDoc
ppr' a
wanted SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
",",
String -> SDoc
text String
"got " SDoc -> SDoc -> SDoc
<> 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 String -> SDoc
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 a. Outputable a => a -> SDoc
ppr
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
Bin Any
extFields_p <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
ModIface
mod_iface <- forall a. Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData NameCacheUpdater
ncu 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}
getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData :: forall a. Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData NameCacheUpdater
ncu BinHandle
bh = do
Bin Any
dict_p <- forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh
Bin Any
data_p <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p
Dictionary
dict <- BinHandle -> IO Dictionary
getDictionary BinHandle
bh
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
data_p
BinHandle
bh <- do
BinHandle
bh <- 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 (forall a. HasCallStack => String -> a
error String
"getSymtabName")
(Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
Bin Any
symtab_p <- forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh
Bin Any
data_p <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
symtab_p
SymbolTable
symtab <- BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable BinHandle
bh NameCacheUpdater
ncu
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
data_p
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 (NameCacheUpdater
-> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName NameCacheUpdater
ncu Dictionary
dict SymbolTable
symtab)
(Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
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
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
Bin (Bin Any)
dict_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)
dict_p_p
Bin (Bin Any)
symtab_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)
symtab_p_p
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 }
FastMutInt
dict_next_ref <- Int -> IO FastMutInt
newFastMutInt Int
0
IORef (UniqFM FastString (Int, FastString))
dict_map_ref <- forall a. a -> IO (IORef a)
newIORef forall key elt. UniqFM key elt
emptyUFM
let bin_dict :: BinDictionary
bin_dict = BinDictionary {
bin_dict_next :: FastMutInt
bin_dict_next = FastMutInt
dict_next_ref,
bin_dict_map :: IORef (UniqFM FastString (Int, FastString))
bin_dict_map = IORef (UniqFM FastString (Int, FastString))
dict_map_ref }
BinHandle
bh <- 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 -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
newWriteState (BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName BinDictionary
bin_dict BinSymbolTable
bin_symtab)
(BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName BinDictionary
bin_dict BinSymbolTable
bin_symtab)
(BinDictionary -> BinHandle -> FastString -> IO ()
putFastString BinDictionary
bin_dict)
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
payload
Bin Any
symtab_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)
symtab_p_p Bin Any
symtab_p
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
symtab_p
Int
symtab_next <- 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 Int
symtab_next UniqFM Name (Int, Name)
symtab_map
case TraceBinIFace
traceBinIface of
TraceBinIFace
QuietBinIFace -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TraceBinIFace SDoc -> IO ()
printer ->
SDoc -> IO ()
printer (String -> SDoc
text String
"writeBinIface:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
symtab_next
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Names")
Bin Any
dict_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)
dict_p_p Bin Any
dict_p
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p
Int
dict_next <- FastMutInt -> IO Int
readFastMutInt FastMutInt
dict_next_ref
UniqFM FastString (Int, FastString)
dict_map <- forall a. IORef a -> IO a
readIORef IORef (UniqFM FastString (Int, FastString))
dict_map_ref
BinHandle -> Int -> UniqFM FastString (Int, FastString) -> IO ()
putDictionary BinHandle
bh Int
dict_next UniqFM FastString (Int, FastString)
dict_map
case TraceBinIFace
traceBinIface of
TraceBinIFace
QuietBinIFace -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TraceBinIFace SDoc -> IO ()
printer ->
SDoc -> IO ()
printer (String -> SDoc
text String
"writeBinIface:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
dict_next
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"dict entries")
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
next_off UniqFM Name (Int, Name)
symtab = do
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
next_off
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
next_offforall 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 -> NameCacheUpdater -> IO SymbolTable
getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable BinHandle
bh NameCacheUpdater
ncu = do
Int
sz <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
[OnDiskName]
od_names <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a. Int -> a -> [a]
replicate Int
sz (forall a. Binary a => BinHandle -> IO a
get BinHandle
bh))
NameCacheUpdater -> forall c. (NameCache -> (NameCache, c)) -> IO c
updateNameCache NameCacheUpdater
ncu forall a b. (a -> b) -> a -> b
$ \NameCache
namecache ->
forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT NameCache
namecache forall a b. (a -> b) -> a -> b
$ do
STArray s Int Name
mut_arr <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s. (Int, Int) -> ST s (STArray s Int Name)
newSTArray_ (Int
0, Int
szforall a. Num a => a -> a -> a
-Int
1)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [OnDiskName]
od_names) forall a b. (a -> b) -> a -> b
$ \(Int
i, OnDiskName
odn) -> do
(NameCache
nc, !Name
n) <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets forall a b. (a -> b) -> a -> b
$ \NameCache
nc -> NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName NameCache
nc OnDiskName
odn
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int Name
mut_arr Int
i Name
n
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put NameCache
nc
SymbolTable
arr <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze STArray s Int Name
mut_arr
NameCache
namecache' <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
forall (m :: * -> *) a. Monad m => a -> m a
return (NameCache
namecache', SymbolTable
arr)
where
newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
newSTArray_ = forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_
type OnDiskName = (Unit, ModuleName, OccName)
fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName NameCache
nc (GenUnit UnitId
pid, ModuleName
mod_name, OccName
occ) =
let mod :: GenModule (GenUnit UnitId)
mod = forall u. u -> ModuleName -> GenModule u
mkModule GenUnit UnitId
pid ModuleName
mod_name
cache :: OrigNameCache
cache = NameCache -> OrigNameCache
nsNames NameCache
nc
in case OrigNameCache
-> GenModule (GenUnit UnitId) -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache GenModule (GenUnit UnitId)
mod OccName
occ of
Just Name
name -> (NameCache
nc, Name
name)
Maybe Name
Nothing ->
let (Unique
uniq, UniqSupply
us) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
nc)
name :: Name
name = Unique -> GenModule (GenUnit UnitId) -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq GenModule (GenUnit UnitId)
mod OccName
occ SrcSpan
noSrcSpan
new_cache :: OrigNameCache
new_cache = OrigNameCache
-> GenModule (GenUnit UnitId) -> OccName -> Name -> OrigNameCache
extendNameCache OrigNameCache
cache GenModule (GenUnit UnitId)
mod OccName
occ Name
name
in ( NameCache
nc{ nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us, nsNames :: OrigNameCache
nsNames = OrigNameCache
new_cache }, Name
name )
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 (GenUnit UnitId)
mod = ASSERT2( isExternalName name, ppr name ) nameModule name
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall unit. GenModule unit -> unit
moduleUnit GenModule (GenUnit UnitId)
mod, forall unit. GenModule unit -> ModuleName
moduleName GenModule (GenUnit UnitId)
mod, Name -> OccName
nameOccName Name
name)
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName BinDictionary
_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 :: NameCacheUpdater
-> Dictionary -> SymbolTable
-> BinHandle -> IO Name
getSymtabName :: NameCacheUpdater
-> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName NameCacheUpdater
_ncu 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 SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (Unique -> (Char, Int)
unpkUnique Unique
u))
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)))
}
putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString BinDictionary
dict BinHandle
bh FastString
fs = BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary
dict FastString
fs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh
allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary { bin_dict_next :: BinDictionary -> FastMutInt
bin_dict_next = FastMutInt
j_r,
bin_dict_map :: BinDictionary -> IORef (UniqFM FastString (Int, FastString))
bin_dict_map = IORef (UniqFM FastString (Int, FastString))
out_r} FastString
f = do
UniqFM FastString (Int, FastString)
out <- forall a. IORef a -> IO a
readIORef IORef (UniqFM FastString (Int, FastString))
out_r
let !uniq :: Unique
uniq = forall a. Uniquable a => a -> Unique
getUnique FastString
f
case forall key elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly UniqFM FastString (Int, FastString)
out Unique
uniq of
Just (Int
j, FastString
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j :: Word32)
Maybe (Int, FastString)
Nothing -> do
Int
j <- FastMutInt -> IO Int
readFastMutInt FastMutInt
j_r
FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
j_r (Int
j forall a. Num a => a -> a -> a
+ Int
1)
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM FastString (Int, FastString))
out_r forall a b. (a -> b) -> a -> b
$! forall key elt. UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly UniqFM FastString (Int, FastString)
out Unique
uniq (Int
j, FastString
f)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j :: Word32)
getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict BinHandle
bh = do
Word32
j <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Dictionary
dict forall i e. Ix i => Array i e -> i -> e
! forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
j :: Word32))
data BinDictionary = BinDictionary {
BinDictionary -> FastMutInt
bin_dict_next :: !FastMutInt,
BinDictionary -> IORef (UniqFM FastString (Int, FastString))
bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString)))
}