{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-}
{-# OPTIONS_GHC -O2 #-}
module GHC.Iface.Binary (
writeBinIface,
readBinIface,
readBinIfaceHeader,
CompressionIFace(..),
getSymtabName,
CheckHiWay(..),
TraceBinIFace(..),
getIfaceWithExtFields,
putIfaceWithExtFields,
getWithUserData,
putWithUserData,
getSymbolTable,
putName,
putSymbolTable,
BinSymbolTable(..),
initWriteIfaceType, initReadIfaceTypeTable,
putAllTables,
) where
import GHC.Prelude
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.Data.FastString (FastString)
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 GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte)
import Control.Monad
import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
import Data.Char
import Data.IORef
import Data.Map.Strict (Map)
import Data.Word
import System.IO.Unsafe
import Data.Typeable (Typeable)
import qualified GHC.Data.Strict as Strict
import Data.Function ((&))
data CheckHiWay = CheckHiWay | IgnoreHiWay
deriving CheckHiWay -> CheckHiWay -> Bool
(CheckHiWay -> CheckHiWay -> Bool)
-> (CheckHiWay -> CheckHiWay -> Bool) -> Eq CheckHiWay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CheckHiWay -> CheckHiWay -> Bool
== :: CheckHiWay -> CheckHiWay -> Bool
$c/= :: CheckHiWay -> CheckHiWay -> Bool
/= :: CheckHiWay -> CheckHiWay -> Bool
Eq
data TraceBinIFace
= TraceBinIFace (SDoc -> IO ())
| QuietBinIFace
data CompressionIFace
= NormalCompression
|
| MaximumCompression
deriving (Int -> CompressionIFace -> ShowS
[CompressionIFace] -> ShowS
CompressionIFace -> String
(Int -> CompressionIFace -> ShowS)
-> (CompressionIFace -> String)
-> ([CompressionIFace] -> ShowS)
-> Show CompressionIFace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompressionIFace -> ShowS
showsPrec :: Int -> CompressionIFace -> ShowS
$cshow :: CompressionIFace -> String
show :: CompressionIFace -> String
$cshowList :: [CompressionIFace] -> ShowS
showList :: [CompressionIFace] -> ShowS
Show, CompressionIFace -> CompressionIFace -> Bool
(CompressionIFace -> CompressionIFace -> Bool)
-> (CompressionIFace -> CompressionIFace -> Bool)
-> Eq CompressionIFace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompressionIFace -> CompressionIFace -> Bool
== :: CompressionIFace -> CompressionIFace -> Bool
$c/= :: CompressionIFace -> CompressionIFace -> Bool
/= :: CompressionIFace -> CompressionIFace -> Bool
Eq, Eq CompressionIFace
Eq CompressionIFace =>
(CompressionIFace -> CompressionIFace -> Ordering)
-> (CompressionIFace -> CompressionIFace -> Bool)
-> (CompressionIFace -> CompressionIFace -> Bool)
-> (CompressionIFace -> CompressionIFace -> Bool)
-> (CompressionIFace -> CompressionIFace -> Bool)
-> (CompressionIFace -> CompressionIFace -> CompressionIFace)
-> (CompressionIFace -> CompressionIFace -> CompressionIFace)
-> Ord CompressionIFace
CompressionIFace -> CompressionIFace -> Bool
CompressionIFace -> CompressionIFace -> Ordering
CompressionIFace -> CompressionIFace -> CompressionIFace
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CompressionIFace -> CompressionIFace -> Ordering
compare :: CompressionIFace -> CompressionIFace -> Ordering
$c< :: CompressionIFace -> CompressionIFace -> Bool
< :: CompressionIFace -> CompressionIFace -> Bool
$c<= :: CompressionIFace -> CompressionIFace -> Bool
<= :: CompressionIFace -> CompressionIFace -> Bool
$c> :: CompressionIFace -> CompressionIFace -> Bool
> :: CompressionIFace -> CompressionIFace -> Bool
$c>= :: CompressionIFace -> CompressionIFace -> Bool
>= :: CompressionIFace -> CompressionIFace -> Bool
$cmax :: CompressionIFace -> CompressionIFace -> CompressionIFace
max :: CompressionIFace -> CompressionIFace -> CompressionIFace
$cmin :: CompressionIFace -> CompressionIFace -> CompressionIFace
min :: CompressionIFace -> CompressionIFace -> CompressionIFace
Ord, CompressionIFace
CompressionIFace -> CompressionIFace -> Bounded CompressionIFace
forall a. a -> a -> Bounded a
$cminBound :: CompressionIFace
minBound :: CompressionIFace
$cmaxBound :: CompressionIFace
maxBound :: CompressionIFace
Bounded, Int -> CompressionIFace
CompressionIFace -> Int
CompressionIFace -> [CompressionIFace]
CompressionIFace -> CompressionIFace
CompressionIFace -> CompressionIFace -> [CompressionIFace]
CompressionIFace
-> CompressionIFace -> CompressionIFace -> [CompressionIFace]
(CompressionIFace -> CompressionIFace)
-> (CompressionIFace -> CompressionIFace)
-> (Int -> CompressionIFace)
-> (CompressionIFace -> Int)
-> (CompressionIFace -> [CompressionIFace])
-> (CompressionIFace -> CompressionIFace -> [CompressionIFace])
-> (CompressionIFace -> CompressionIFace -> [CompressionIFace])
-> (CompressionIFace
-> CompressionIFace -> CompressionIFace -> [CompressionIFace])
-> Enum CompressionIFace
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: CompressionIFace -> CompressionIFace
succ :: CompressionIFace -> CompressionIFace
$cpred :: CompressionIFace -> CompressionIFace
pred :: CompressionIFace -> CompressionIFace
$ctoEnum :: Int -> CompressionIFace
toEnum :: Int -> CompressionIFace
$cfromEnum :: CompressionIFace -> Int
fromEnum :: CompressionIFace -> Int
$cenumFrom :: CompressionIFace -> [CompressionIFace]
enumFrom :: CompressionIFace -> [CompressionIFace]
$cenumFromThen :: CompressionIFace -> CompressionIFace -> [CompressionIFace]
enumFromThen :: CompressionIFace -> CompressionIFace -> [CompressionIFace]
$cenumFromTo :: CompressionIFace -> CompressionIFace -> [CompressionIFace]
enumFromTo :: CompressionIFace -> CompressionIFace -> [CompressionIFace]
$cenumFromThenTo :: CompressionIFace
-> CompressionIFace -> CompressionIFace -> [CompressionIFace]
enumFromThenTo :: CompressionIFace
-> CompressionIFace -> CompressionIFace -> [CompressionIFace]
Enum)
instance Outputable CompressionIFace where
ppr :: CompressionIFace -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (CompressionIFace -> String) -> CompressionIFace -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompressionIFace -> String
forall a. Show a => a -> String
show
readBinIfaceHeader
:: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> FilePath
-> IO (Fingerprint, ReadBinHandle)
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 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TraceBinIFace SDoc -> IO ()
printer -> SDoc -> IO ()
printer (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
": " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Wanted " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
ppr' a
wanted SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
",",
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"got " SDoc -> SDoc -> SDoc
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 =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
wanted a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
got) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
ProgramError
(String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (wanted " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
wanted
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
got String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
bh <- String -> IO ReadBinHandle
Binary.readBinMem String
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 = Integer -> String
forall a. Show a => a -> String
show Integer
hiVersion
wantedGot "Version" our_ver check_ver text
errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_tag <- get bh
let tag = Profile -> String
profileBuildTag Profile
profile
wantedGot "Way" tag check_tag text
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
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO (ModIface_ 'ModIfaceFinal)
readBinIface Profile
profile NameCache
name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIface String
hi_path = do
(src_hash, bh) <- Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO (Fingerprint, ReadBinHandle)
readBinIfaceHeader Profile
profile NameCache
name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIface String
hi_path
mod_iface <- getIfaceWithExtFields name_cache bh
return $ mod_iface
& addSourceFingerprint src_hash
getIfaceWithExtFields :: NameCache -> ReadBinHandle -> IO ModIface
getIfaceWithExtFields :: NameCache -> ReadBinHandle -> IO (ModIface_ 'ModIfaceFinal)
getIfaceWithExtFields NameCache
name_cache ReadBinHandle
bh = do
start <- ReadBinHandle -> IO (Bin (ZonkAny 1))
forall {k} (a :: k). ReadBinHandle -> IO (Bin a)
tellBinReader ReadBinHandle
bh
extFields_p_rel <- getRelBin bh
mod_iface <- getWithUserData name_cache bh
seekBinReaderRel bh extFields_p_rel
extFields <- get bh
modIfaceBinData <- freezeBinHandle bh start
pure $ mod_iface
& set_mi_ext_fields extFields
& set_mi_hi_bytes (FullIfaceBinHandle $ Strict.Just modIfaceBinData)
getWithUserData :: Binary a => NameCache -> ReadBinHandle -> IO a
getWithUserData :: forall a. Binary a => NameCache -> ReadBinHandle -> IO a
getWithUserData NameCache
name_cache ReadBinHandle
bh = do
bh <- NameCache -> ReadBinHandle -> IO ReadBinHandle
getTables NameCache
name_cache ReadBinHandle
bh
get bh
getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle
getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle
getTables NameCache
name_cache ReadBinHandle
bh = do
bhRef <- ReaderUserData -> IO (IORef ReaderUserData)
forall a. a -> IO (IORef a)
newIORef (String -> ReaderUserData
forall a. HasCallStack => String -> a
error String
"used too soon")
ud <- unsafeInterleaveIO (readIORef bhRef)
fsReaderTable <- initFastStringReaderTable
nameReaderTable <- initNameReaderTable name_cache
ifaceTypeReaderTable <- initReadIfaceTypeTable ud
let
decodeReaderTable :: Typeable a => ReaderTable a -> ReadBinHandle -> IO ReadBinHandle
decodeReaderTable ReaderTable a
tbl ReadBinHandle
bh0 = do
table <- ReadBinHandle -> IO (SymbolTable a) -> IO (SymbolTable a)
forall a. ReadBinHandle -> IO a -> IO a
Binary.forwardGetRel ReadBinHandle
bh (ReaderTable a -> ReadBinHandle -> IO (SymbolTable a)
forall a. ReaderTable a -> ReadBinHandle -> IO (SymbolTable a)
getTable ReaderTable a
tbl ReadBinHandle
bh0)
let binaryReader = ReaderTable a -> SymbolTable a -> BinaryReader a
forall a. ReaderTable a -> SymbolTable a -> BinaryReader a
mkReaderFromTable ReaderTable a
tbl SymbolTable a
table
pure $ addReaderToUserData binaryReader bh0
bhFinal <- foldM (\ReadBinHandle
bh0 ReadBinHandle -> IO ReadBinHandle
act -> ReadBinHandle -> IO ReadBinHandle
act ReadBinHandle
bh0) bh
[ decodeReaderTable fsReaderTable
, decodeReaderTable nameReaderTable
, decodeReaderTable ifaceTypeReaderTable
]
writeIORef bhRef (getReaderUserData bhFinal)
pure bhFinal
writeBinIface :: Profile -> TraceBinIFace -> CompressionIFace -> FilePath -> ModIface -> IO ()
writeBinIface :: Profile
-> TraceBinIFace
-> CompressionIFace
-> String
-> ModIface_ 'ModIfaceFinal
-> IO ()
writeBinIface Profile
profile TraceBinIFace
traceBinIface CompressionIFace
compressionLevel String
hi_path ModIface_ 'ModIfaceFinal
mod_iface = do
case TraceBinIFace
traceBinIface of
TraceBinIFace
QuietBinIFace -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
TraceBinIFace SDoc -> IO ()
printer -> do
SDoc -> IO ()
printer (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"writeBinIface compression level:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CompressionIFace -> SDoc
forall a. Outputable a => a -> SDoc
ppr CompressionIFace
compressionLevel)
bh <- Int -> IO WriteBinHandle
openBinMem Int
initBinMemSize
let platform = Profile -> Platform
profilePlatform Profile
profile
put_ bh (binaryInterfaceMagic platform)
put_ bh (show hiVersion)
let tag = Profile -> String
profileBuildTag Profile
profile
put_ bh tag
put_ bh (mi_src_hash mod_iface)
putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface
writeBinMem bh hi_path
putIfaceWithExtFields :: TraceBinIFace -> CompressionIFace -> WriteBinHandle -> ModIface -> IO ()
putIfaceWithExtFields :: TraceBinIFace
-> CompressionIFace
-> WriteBinHandle
-> ModIface_ 'ModIfaceFinal
-> IO ()
putIfaceWithExtFields TraceBinIFace
traceBinIface CompressionIFace
compressionLevel WriteBinHandle
bh ModIface_ 'ModIfaceFinal
mod_iface =
case ModIface_ 'ModIfaceFinal -> IfaceBinHandle 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBinHandle phase
mi_hi_bytes ModIface_ 'ModIfaceFinal
mod_iface of
FullIfaceBinHandle Maybe FullBinData
Strict.Nothing -> do
WriteBinHandle -> (() -> IO ()) -> IO () -> IO ()
forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPutRel_ WriteBinHandle
bh (\()
_ -> WriteBinHandle -> ExtensibleFields -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (ModIface_ 'ModIfaceFinal -> ExtensibleFields
forall (phase :: ModIfacePhase).
ModIface_ phase -> ExtensibleFields
mi_ext_fields ModIface_ 'ModIfaceFinal
mod_iface)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TraceBinIFace
-> CompressionIFace
-> WriteBinHandle
-> ModIface_ 'ModIfaceFinal
-> IO ()
forall a.
Binary a =>
TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO ()
putWithUserData TraceBinIFace
traceBinIface CompressionIFace
compressionLevel WriteBinHandle
bh ModIface_ 'ModIfaceFinal
mod_iface
FullIfaceBinHandle (Strict.Just FullBinData
binData) -> WriteBinHandle -> FullBinData -> IO ()
putFullBinData WriteBinHandle
bh FullBinData
binData
putWithUserData :: Binary a => TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO ()
putWithUserData :: forall a.
Binary a =>
TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO ()
putWithUserData TraceBinIFace
traceBinIface CompressionIFace
compressionLevel WriteBinHandle
bh a
payload = do
(name_count, fs_count, ifacetype_count, _b) <- CompressionIFace
-> WriteBinHandle
-> (WriteBinHandle -> IO (Bin a))
-> IO (Int, Int, Int, Bin a)
forall b.
CompressionIFace
-> WriteBinHandle
-> (WriteBinHandle -> IO b)
-> IO (Int, Int, Int, b)
putWithTables CompressionIFace
compressionLevel WriteBinHandle
bh (\WriteBinHandle
bh' -> WriteBinHandle -> a -> IO (Bin a)
forall a. Binary a => WriteBinHandle -> a -> IO (Bin a)
put WriteBinHandle
bh' a
payload)
case traceBinIface of
TraceBinIFace
QuietBinIFace -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TraceBinIFace SDoc -> IO ()
printer -> do
SDoc -> IO ()
printer (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"writeBinIface:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
name_count
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Names")
SDoc -> IO ()
printer (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"writeBinIface:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
fs_count
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dict entries")
SDoc -> IO ()
printer (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"writeBinIface:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
ifacetype_count
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"iface type entries")
putWithTables :: CompressionIFace -> WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, Int, b)
putWithTables :: forall b.
CompressionIFace
-> WriteBinHandle
-> (WriteBinHandle -> IO b)
-> IO (Int, Int, Int, b)
putWithTables CompressionIFace
compressionLevel WriteBinHandle
bh' WriteBinHandle -> IO b
put_payload = do
(fast_wt, fsWriter) <- IO (WriterTable, BinaryWriter FastString)
initFastStringWriterTable
(name_wt, nameWriter) <- initNameWriterTable
(ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel
let writerUserData = [SomeBinaryWriter] -> WriterUserData
mkWriterUserData
[ forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter @FastString BinaryWriter FastString
fsWriter
, forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter @Name BinaryWriter Name
nameWriter
, forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter @BindingName (BinaryWriter BindingName -> SomeBinaryWriter)
-> BinaryWriter BindingName -> SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> BindingName -> IO ())
-> BinaryWriter BindingName
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter (\WriteBinHandle
bh BindingName
name -> BinaryWriter Name -> WriteBinHandle -> Name -> IO ()
forall s. BinaryWriter s -> WriteBinHandle -> s -> IO ()
putEntry BinaryWriter Name
nameWriter WriteBinHandle
bh (BindingName -> Name
getBindingName BindingName
name))
, forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter @IfaceType BinaryWriter IfaceType
ifaceTypeWriter
]
let bh = WriteBinHandle -> WriterUserData -> WriteBinHandle
setWriterUserData WriteBinHandle
bh' WriterUserData
writerUserData
([fs_count, name_count, ifacetype_count] , r) <-
putAllTables bh [fast_wt, name_wt, ifaceType_wt] $ do
put_payload bh
return (name_count, fs_count, ifacetype_count, r)
putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)
putAllTables :: forall b. WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)
putAllTables WriteBinHandle
_ [] IO b
act = do
a <- IO b
act
pure ([], a)
putAllTables WriteBinHandle
bh (WriterTable
x : [WriterTable]
xs) IO b
act = do
(r, (res, a)) <- WriteBinHandle
-> (([Int], b) -> IO Int) -> IO ([Int], b) -> IO (Int, ([Int], b))
forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPutRel WriteBinHandle
bh (IO Int -> ([Int], b) -> IO Int
forall a b. a -> b -> a
const (IO Int -> ([Int], b) -> IO Int) -> IO Int -> ([Int], b) -> IO Int
forall a b. (a -> b) -> a -> b
$ WriterTable -> WriteBinHandle -> IO Int
putTable WriterTable
x WriteBinHandle
bh) (IO ([Int], b) -> IO (Int, ([Int], b)))
-> IO ([Int], b) -> IO (Int, ([Int], b))
forall a b. (a -> b) -> a -> b
$ do
WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)
forall b. WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b)
putAllTables WriteBinHandle
bh [WriterTable]
xs IO b
act
pure (r : res, a)
initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = Int
1024 Int -> Int -> Int
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 = Word32 -> FixedLengthEncoding Word32
forall a. a -> FixedLengthEncoding a
FixedLengthEncoding Word32
0x1face
| Bool
otherwise = Word32 -> FixedLengthEncoding Word32
forall a. a -> FixedLengthEncoding a
FixedLengthEncoding Word32
0x1face64
initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType)
initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType)
initReadIfaceTypeTable ReaderUserData
ud = do
ReaderTable IfaceType -> IO (ReaderTable IfaceType)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReaderTable IfaceType -> IO (ReaderTable IfaceType))
-> ReaderTable IfaceType -> IO (ReaderTable IfaceType)
forall a b. (a -> b) -> a -> b
$
ReaderTable
{ getTable :: ReadBinHandle -> IO (SymbolTable IfaceType)
getTable = (ReadBinHandle -> IO IfaceType)
-> ReadBinHandle -> IO (SymbolTable IfaceType)
forall a.
(ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a)
getGenericSymbolTable (\ReadBinHandle
bh -> (ReadBinHandle -> IO IfaceType) -> ReadBinHandle -> IO IfaceType
forall a. (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
lazyGet' HasCallStack => ReadBinHandle -> IO IfaceType
ReadBinHandle -> IO IfaceType
getIfaceType (ReadBinHandle -> ReaderUserData -> ReadBinHandle
setReaderUserData ReadBinHandle
bh ReaderUserData
ud))
, mkReaderFromTable :: SymbolTable IfaceType -> BinaryReader IfaceType
mkReaderFromTable = \SymbolTable IfaceType
tbl -> (ReadBinHandle -> IO IfaceType) -> BinaryReader IfaceType
forall s. (ReadBinHandle -> IO s) -> BinaryReader s
mkReader (SymbolTable IfaceType -> ReadBinHandle -> IO IfaceType
forall a. Binary a => SymbolTable a -> ReadBinHandle -> IO a
getGenericSymtab SymbolTable IfaceType
tbl)
}
initWriteIfaceType :: CompressionIFace -> IO (WriterTable, BinaryWriter IfaceType)
initWriteIfaceType :: CompressionIFace -> IO (WriterTable, BinaryWriter IfaceType)
initWriteIfaceType CompressionIFace
compressionLevel = do
sym_tab <- forall (m :: * -> *). TrieMap m => IO (GenericSymbolTable m)
initGenericSymbolTable @(Map IfaceType)
pure
( WriterTable
{ putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType)
}
, mkWriter $ ifaceWriter sym_tab
)
where
ifaceWriter :: GenericSymbolTable (Map IfaceType)
-> WriteBinHandle -> IfaceType -> IO ()
ifaceWriter GenericSymbolTable (Map IfaceType)
sym_tab = case CompressionIFace
compressionLevel of
CompressionIFace
NormalCompression -> WriteBinHandle -> IfaceType -> IO ()
literalIfaceTypeSerialiser
CompressionIFace
SafeExtraCompression -> GenericSymbolTable (Map IfaceType)
-> WriteBinHandle -> IfaceType -> IO ()
forall {m :: * -> *}.
(Key m ~ IfaceType, TrieMap m) =>
GenericSymbolTable m -> WriteBinHandle -> IfaceType -> IO ()
ifaceTyConAppSerialiser GenericSymbolTable (Map IfaceType)
sym_tab
CompressionIFace
MaximumCompression -> GenericSymbolTable (Map IfaceType)
-> WriteBinHandle -> Key (Map IfaceType) -> IO ()
forall {m :: * -> *}.
TrieMap m =>
GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
fullIfaceTypeSerialiser GenericSymbolTable (Map IfaceType)
sym_tab
ifaceTyConAppSerialiser :: GenericSymbolTable m -> WriteBinHandle -> IfaceType -> IO ()
ifaceTyConAppSerialiser GenericSymbolTable m
sym_tab WriteBinHandle
bh IfaceType
ty = case IfaceType
ty of
IfaceTyConApp {} -> do
WriteBinHandle -> Word8 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Word8
ifaceTypeSharedByte
GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
forall {m :: * -> *}.
TrieMap m =>
GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
putGenericSymTab GenericSymbolTable m
sym_tab WriteBinHandle
bh IfaceType
Key m
ty
IfaceType
_ -> WriteBinHandle -> IfaceType -> IO ()
putIfaceType WriteBinHandle
bh IfaceType
ty
fullIfaceTypeSerialiser :: GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
fullIfaceTypeSerialiser GenericSymbolTable m
sym_tab WriteBinHandle
bh Key m
ty = do
WriteBinHandle -> Word8 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Word8
ifaceTypeSharedByte
GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
forall {m :: * -> *}.
TrieMap m =>
GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
putGenericSymTab GenericSymbolTable m
sym_tab WriteBinHandle
bh Key m
ty
literalIfaceTypeSerialiser :: WriteBinHandle -> IfaceType -> IO ()
literalIfaceTypeSerialiser = WriteBinHandle -> IfaceType -> IO ()
putIfaceType
initNameReaderTable :: NameCache -> IO (ReaderTable Name)
initNameReaderTable :: NameCache -> IO (ReaderTable Name)
initNameReaderTable NameCache
cache = do
ReaderTable Name -> IO (ReaderTable Name)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReaderTable Name -> IO (ReaderTable Name))
-> ReaderTable Name -> IO (ReaderTable Name)
forall a b. (a -> b) -> a -> b
$
ReaderTable
{ getTable :: ReadBinHandle -> IO (SymbolTable Name)
getTable = \ReadBinHandle
bh -> ReadBinHandle -> NameCache -> IO (SymbolTable Name)
getSymbolTable ReadBinHandle
bh NameCache
cache
, mkReaderFromTable :: SymbolTable Name -> BinaryReader Name
mkReaderFromTable = \SymbolTable Name
tbl -> (ReadBinHandle -> IO Name) -> BinaryReader Name
forall s. (ReadBinHandle -> IO s) -> BinaryReader s
mkReader (SymbolTable Name -> ReadBinHandle -> IO Name
getSymtabName SymbolTable Name
tbl)
}
data BinSymbolTable = BinSymbolTable {
BinSymbolTable -> FastMutInt
bin_symtab_next :: !FastMutInt,
BinSymbolTable -> IORef (UniqFM Name (Int, Name))
bin_symtab_map :: !(IORef (UniqFM Name (Int,Name)))
}
initNameWriterTable :: IO (WriterTable, BinaryWriter Name)
initNameWriterTable :: IO (WriterTable, BinaryWriter Name)
initNameWriterTable = do
symtab_next <- Int -> IO FastMutInt
newFastMutInt Int
0
symtab_map <- newIORef emptyUFM
let 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
}
let put_symtab WriteBinHandle
bh = do
name_count <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
symtab_map <- readIORef symtab_map
putSymbolTable bh name_count symtab_map
pure name_count
return
( WriterTable
{ putTable = put_symtab
}
, mkWriter $ putName bin_symtab
)
putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int, Name) -> IO ()
putSymbolTable WriteBinHandle
bh Int
name_count UniqFM Name (Int, Name)
symtab = do
WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Int
name_count
let names :: [Name]
names = SymbolTable Name -> [Name]
forall i e. Array i e -> [e]
elems ((Int, Int) -> [(Int, Name)] -> SymbolTable Name
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,Int
name_countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (UniqFM Name (Int, Name) -> [(Int, Name)]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM Name (Int, Name)
symtab))
(Name -> IO ()) -> [Name] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> WriteBinHandle -> Name -> UniqFM Name (Int, Name) -> IO ()
forall {k} (key :: k).
WriteBinHandle -> Name -> UniqFM key (Int, Name) -> IO ()
serialiseName WriteBinHandle
bh Name
n UniqFM Name (Int, Name)
symtab) [Name]
names
getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name)
getSymbolTable ReadBinHandle
bh NameCache
name_cache = do
sz <- ReadBinHandle -> IO Int
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh :: IO Int
updateNameCache' name_cache $ \OrigNameCache
cache0 -> do
mut_arr <- (Int, Int) -> IO (IOArray Int Name)
forall i. Ix i => (i, i) -> IO (IOArray i Name)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
0, Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) :: IO (IOArray Int Name)
cache <- foldGet' (fromIntegral sz) bh cache0 $ \Word
i (Unit
uid, ModuleName
mod_name, OccName
occ) OrigNameCache
cache -> do
let mod :: GenModule Unit
mod = Unit -> ModuleName -> GenModule Unit
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
IOArray Int Name -> Int -> Name -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Int Name
mut_arr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i) Name
name
OrigNameCache -> IO OrigNameCache
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return OrigNameCache
cache
Maybe Name
Nothing -> do
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
name_cache
let name = Unique -> GenModule Unit -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq GenModule Unit
mod OccName
occ SrcSpan
noSrcSpan
new_cache = OrigNameCache -> GenModule Unit -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache GenModule Unit
mod OccName
occ Name
name
writeArray mut_arr (fromIntegral i) name
return new_cache
arr <- unsafeFreeze mut_arr
return (cache, arr)
serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName :: forall {k} (key :: k).
WriteBinHandle -> Name -> UniqFM key (Int, Name) -> IO ()
serialiseName WriteBinHandle
bh Name
name UniqFM key (Int, Name)
_ = do
let mod :: GenModule Unit
mod = Bool -> SDoc -> GenModule Unit -> GenModule Unit
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isExternalName Name
name) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) (HasDebugCallStack => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
name)
WriteBinHandle -> (Unit, ModuleName, OccName) -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (GenModule Unit -> Unit
forall unit. GenModule unit -> unit
moduleUnit GenModule Unit
mod, GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
mod, Name -> OccName
nameOccName Name
name)
putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO ()
putName 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 }
WriteBinHandle
bh Name
name
| Name -> Bool
isKnownKeyName Name
name
, let (Char
c, Word64
u) = Unique -> (Char, Word64)
unpkUnique (Name -> Unique
nameUnique Name
name)
=
WriteBinHandle -> Word32 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Word32
0x80000000
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
22)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
u :: Word32))
| Bool
otherwise
= do symtab_map <- IORef (UniqFM Name (Int, Name)) -> IO (UniqFM Name (Int, Name))
forall a. IORef a -> IO a
readIORef IORef (UniqFM Name (Int, Name))
symtab_map_ref
case lookupUFM symtab_map name of
Just (Int
off,Name
_) -> WriteBinHandle -> Word32 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
Maybe (Int, Name)
Nothing -> do
off <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
put_ bh (fromIntegral off :: Word32)
getSymtabName :: SymbolTable Name
-> ReadBinHandle -> IO Name
getSymtabName :: SymbolTable Name -> ReadBinHandle -> IO Name
getSymtabName SymbolTable Name
symtab ReadBinHandle
bh = do
i :: Word32 <- ReadBinHandle -> IO Word32
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
case i .&. 0xC0000000 of
Word32
0x00000000 -> Name -> IO Name
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> IO Name) -> Name -> IO Name
forall a b. (a -> b) -> a -> b
$! SymbolTable Name
symtab SymbolTable Name -> Int -> Name
forall i e. Ix i => Array i e -> i -> e
! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i
Word32
0x80000000 ->
let
tag :: Char
tag = Int -> Char
chr (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
i Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x3FC00000) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
22))
ix :: Word64
ix = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x003FFFFF
u :: Unique
u = Char -> Word64 -> Unique
mkUnique Char
tag Word64
ix
in
Name -> IO Name
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> IO Name) -> Name -> IO Name
forall a b. (a -> b) -> a -> b
$! case Unique -> Maybe Name
lookupKnownKeyName Unique
u of
Maybe Name
Nothing -> String -> SDoc -> Name
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSymtabName:unknown known-key unique"
(Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word32
i SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
tag SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Word64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word64
ix)
Just Name
n -> Name
n
Word32
_ -> String -> SDoc -> IO Name
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSymtabName:unknown name tag" (Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word32
i)