{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-}

--
--  (c) The University of Glasgow 2002-2006
--

{-# OPTIONS_GHC -O2 #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected

-- | Binary interface file support.
module GHC.Iface.Binary (
        -- * Public API for interface file serialisation
        writeBinIface,
        readBinIface,
        readBinIfaceHeader,
        CompressionIFace(..),
        getSymtabName,
        CheckHiWay(..),
        TraceBinIFace(..),
        getIfaceWithExtFields,
        putIfaceWithExtFields,
        getWithUserData,
        putWithUserData,

        -- * Internal serialisation functions
        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 ((&))


-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
--

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

-- | The compression/deduplication level of 'ModIface' files.
--
-- A 'ModIface' contains many duplicated symbols and names. To keep interface
-- files small, we deduplicate them during serialisation.
-- It is impossible to write an interface file with *no* compression/deduplication.
--
-- We support different levels of compression/deduplication, with different
-- trade-offs for run-time performance and memory usage.
-- If you don't have any specific requirements, then 'SafeExtraCompression' is a good default.
data CompressionIFace
  = NormalCompression
  -- ^ Perform the normal compression operations,
  -- such as deduplicating 'Name's and 'FastString's
  | SafeExtraCompression
  -- ^ Perform some extra compression steps that have minimal impact
  -- on the run-time of 'ghc'.
  --
  -- This reduces the size of '.hi' files significantly in some cases
  -- and reduces overall memory usage in certain scenarios.
  | MaximumCompression
  -- ^ Try to compress as much as possible.
  --
  -- Yields the smallest '.hi' files but at the cost of additional run-time.
  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

-- | Read an interface file header, checking the magic number, version, and
-- way. Returns the hash of the source file and a BinHandle which points at the
-- start of the rest of the interface file data.
readBinIfaceHeader
  :: Profile
  -> NameCache
  -> CheckHiWay
  -> TraceBinIFace
  -> FilePath
  -> IO (Fingerprint, ReadBinHandle)
readBinIfaceHeader :: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO (Fingerprint, ReadBinHandle)
readBinIfaceHeader 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 =
            -- This will be caught by readIface which will emit an error
            -- msg containing the iface module name.
            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

    -- Read the magic number to check that this really is a GHC .hi file
    -- (This magic number does not change when we change
    --  GHC interface file format)
    magic <- get bh
    wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength)
    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
        (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic)

    -- Check the interface file version and profile tag.
    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)

-- | Read an interface file.
--
-- See Note [Deduplication during iface binary serialisation] for details.
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 offset for the byte array that contains the serialised 'ModIface'.
  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
  -- Store the 'ModIface' byte array, so that we can avoid serialisation if
  -- the 'ModIface' isn't modified.
  -- See Note [Sharing of ModIface]
  modIfaceBinData <- freezeBinHandle bh start
  pure $ mod_iface
    & set_mi_ext_fields extFields
    & set_mi_hi_bytes (FullIfaceBinHandle $ Strict.Just modIfaceBinData)

-- | This performs a get action after reading the dictionary and symbol
-- table. It is necessary to run this before trying to deserialise any
-- Names or FastStrings.
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

-- | Setup a BinHandle to read something written using putWithTables
--
-- Reading names has the side effect of adding them into the given NameCache.
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")
    -- It is important this is passed to 'getTable'
    -- See Note [Lazy ReaderUserData during IfaceType serialisation]
    ud <- unsafeInterleaveIO (readIORef bhRef)

    fsReaderTable <- initFastStringReaderTable
    nameReaderTable <- initNameReaderTable name_cache
    ifaceTypeReaderTable <- initReadIfaceTypeTable ud

    let -- For any 'ReaderTable', we decode the table that is found at the location
        -- the forward reference points to.
        -- After decoding the table, we create a 'BinaryReader' and immediately
        -- add it to the 'ReaderUserData' of 'ReadBinHandle'.
        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

    -- Decode all the tables and populate the 'ReaderUserData'.
    bhFinal <- foldM (\ReadBinHandle
bh0 ReadBinHandle -> IO ReadBinHandle
act -> ReadBinHandle -> IO ReadBinHandle
act ReadBinHandle
bh0) bh
      -- The order of these deserialisation matters!
      --
      -- See Note [Order of deduplication tables during iface binary serialisation] for details.
      [ decodeReaderTable fsReaderTable
      , decodeReaderTable nameReaderTable
      , decodeReaderTable ifaceTypeReaderTable
      ]

    writeIORef bhRef (getReaderUserData bhFinal)
    pure bhFinal

-- | Write an interface file.
--
-- See Note [Deduplication during iface binary serialisation] for details.
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)

    -- The version, profile tag, and source hash go next
    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

    -- And send the result to the file
    writeBinMem bh hi_path

-- | Puts the 'ModIface' to the 'WriteBinHandle'.
--
-- This avoids serialisation of the 'ModIface' if the fields 'mi_hi_bytes' contains a
-- 'Just' value. This field is populated by reading the 'ModIface' using
-- 'getIfaceWithExtFields' and not modifying it in any way afterwards.
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

-- | Put a piece of data with an initialised `UserData` field. This
-- is necessary if you want to serialise Names or FastStrings.
-- It also writes a symbol table and the dictionary.
-- This segment should be read using `getWithUserData`.
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")

-- | Write name/symbol/ifacetype tables
--
-- 1. setup the given BinHandle with Name/FastString/IfaceType table handling
-- 2. write the following
--    - FastString table pointer
--    - Name table pointer
--    - IfaceType table pointer
--    - payload
--    - IfaceType table
--    - Name table
--    - FastString table
--
-- It returns (number of names, number of FastStrings, number of IfaceTypes, payload write result)
--
-- See Note [Order of deduplication tables during iface binary serialisation]
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
  -- Initialise deduplicating tables.
  (fast_wt, fsWriter) <- IO (WriterTable, BinaryWriter FastString)
initFastStringWriterTable
  (name_wt, nameWriter) <- initNameWriterTable
  (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel

  -- Initialise the 'WriterUserData'.
  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
        -- We sometimes serialise binding and non-binding names differently, but
        -- not during 'ModIface' serialisation. Here, we serialise both to the same
        -- deduplication table.
        --
        -- See Note [Binary UserData]
        , 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) <-
    -- The order of these entries matters!
    --
    -- See Note [Order of deduplication tables during iface binary serialisation] for details.
    putAllTables bh [fast_wt, name_wt, ifaceType_wt] $ do
      put_payload bh

  return (name_count, fs_count, ifacetype_count, r)

-- | Write all deduplication tables to disk after serialising the
-- main payload.
--
-- Writes forward pointers to the deduplication tables before writing the payload
-- to allow deserialisation *before* the payload is read again.
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)

-- | Initial ram buffer to allocate for writing interface files
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


{-
Note [Deduplication during iface binary serialisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we serialise a 'ModIface', many symbols are redundant.
For example, there can be many duplicated 'FastString's and 'Name's.
To save space, we deduplicate duplicated symbols, such as 'FastString' and 'Name',
by maintaining a table of already seen symbols.

Besides saving a lot of disk space, this additionally enables us to automatically share
these symbols when we read the 'ModIface' from disk, without additional mechanisms such as 'FastStringTable'.

The general idea is, when serialising a value of type 'Name', we first have to create a deduplication
table (see 'putWithTables.initNameWriterTable' for example). Then, we create a 'BinaryWriter' function
which we add to the 'WriterUserData'. When this 'BinaryWriter' is used to serialise a value of type 'Name',
it looks up whether we have seen this value before. If so, we write an index to disk.
If we haven't seen the value before, we add it to the deduplication table and produce a new index.

Both the 'ReaderUserData' and 'WriterUserData' can contain many 'BinaryReader's and 'BinaryWriter's
respectively, which can each individually be tweaked to use a deduplication table, or to serialise
the value without deduplication.

After the payload (e.g., the 'ModIface') has been serialised to disk, we serialise the deduplication tables
to disk. This happens in 'putAllTables', where we serialise all tables that we use during 'ModIface'
serialisation. See 'initNameWriterTable' and 'putSymbolTable' for an implementation example.
This uses the 'real' serialisation function, e.g., 'serialiseName'.
However, these tables need to be deserialised before we can read the 'ModIface' from disk.
Thus, we write before the 'ModIface' a forward pointer to the deduplication table, so we can
read this table before deserialising the 'ModIface'.

To add a deduplication table for a type, let us assume 'IfaceTyCon', you need to do the following:

* The 'Binary' instance 'IfaceTyCon' needs to dynamically look up the serialiser function instead of
  serialising the value of 'IfaceTyCon'. It needs to look up the serialiser in the 'ReaderUserData' and
  'WriterUserData' respectively.
  This allows us to change the serialisation of 'IfaceTyCon' at run-time.
  We can still serialise 'IfaceTyCon' to disk directly, or use a deduplication table to reduce the size of
  the .hi file.

  For example:

  @
    instance Binary IfaceTyCon where
      put_ bh ty = case findUserDataWriter (Proxy @IfaceTyCon) bh of
        tbl -> putEntry tbl bh ty
      get bh     = case findUserDataReader (Proxy @IfaceTyCon) bh of
        tbl -> getEntry tbl bh
  @

  We include the signatures of 'findUserDataWriter' and 'findUserDataReader' to make this code example
  easier to understand:

  @
    findUserDataReader :: Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a
    findUserDataWriter :: Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a
  @

  where 'BinaryReader' and 'BinaryWriter' correspond to the 'Binary' class methods
  'get' and 'put_' respectively, thus:

  @
    newtype BinaryReader s = BinaryReader { getEntry :: ReadBinHandle -> IO s }

    newtype BinaryWriter s = BinaryWriter { putEntry :: WriteBinHandle -> s -> IO () }
  @

  'findUserData*' looks up the serialisation function for 'IfaceTyCon', which we then subsequently
  use to serialise said 'IfaceTyCon'. If no such serialiser can be found, 'findUserData*'
  crashes at run-time.

* Whenever a value of 'IfaceTyCon' needs to be serialised, there are two serialisation functions involved:

  * The literal serialiser that puts/gets the value to/from disk:
      Writes or reads a value of type 'IfaceTyCon' from the 'Write/ReadBinHandle'.
      This serialiser is primarily used to write the values stored in the deduplication table.
      It is also used to read the values from disk.

  * The deduplicating serialiser:
      Replaces the serialised value of 'IfaceTyCon' with an offset that is stored in the
      deduplication table.
      This serialiser is used while serialising the payload.

  We need to add the deduplicating serialiser to the 'ReaderUserData' and 'WriterUserData'
  respectively, so that 'findUserData*' can find them.

  For example, adding a serialiser for writing 'IfaceTyCon's:

  @
    let bh0 :: WriteBinHandle = ...
        putIfaceTyCon = ... -- Serialises 'IfaceTyCon' to disk
        bh = addWriterToUserData (mkSomeBinaryWriter putIfaceTyCon) bh0
  @

  Naturally, you have to do something similar for reading values of 'IfaceTyCon'.

  The provided code example implements the previous behaviour:
  serialise all values of type 'IfaceTyCon' directly. No deduplication is happening.

  Now, instead of literally putting the value, we can introduce a deduplication table!
  Instead of specifying 'putIfaceTyCon', which writes a value of 'IfaceTyCon' directly to disk,
  we provide a function that looks up values in a table and provides an index of each value
  we have already seen.
  If the particular 'IfaceTyCon' we want to serialise isn't already in the de-dup table,
  we allocate a new index and extend the table.

  See the definition of 'initNameWriterTable' and 'initNameReaderTable' for example deduplication tables.

* Storing the deduplication table.

  After the deduplicating the elements in the payload (e.g., 'ModIface'), we now have a deduplication
  table full with all the values.
  We serialise this table to disk using the real serialiser (e.g., 'putIfaceTyCon').

  When serialisation is complete, we write out the de-dup table in 'putAllTables',
  serialising each 'IfaceTyCon' in the table.  Of course, doing so might in turn serialise
  another de-dup'd thing (e.g. a FastString), thereby extending its respective de-dup table.

Note [Order of deduplication tables during iface binary serialisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Serialisation of 'ModIface' uses tables to deduplicate symbols that occur often.
See Note [Deduplication during iface binary serialisation].

After 'ModIface' has been written to disk, we write the deduplication tables.
Writing a table may add additional entries to *other* deduplication tables, thus
we need to make sure that the symbol table we serialise only depends on
deduplication tables that haven't been written to disk yet.

For example, assume we maintain deduplication tables for 'FastString' and 'Name'.
The symbol 'Name' depends on 'FastString', so serialising a 'Name' may add a 'FastString'
to the 'FastString' deduplication table.
Thus, 'Name' table needs to be serialised to disk before the 'FastString' table.

When we read the 'ModIface' from disk, we consequentially need to read the 'FastString'
deduplication table from disk, before we can deserialise the 'Name' deduplication table.
Therefore, before we serialise the tables, we write forward pointers that allow us to jump ahead
to the table we need to deserialise first.
What deduplication tables exist and the order of serialisation is currently statically specified
in 'putWithTables'. 'putWithTables' also takes care of the serialisation of used deduplication tables.
The deserialisation of the deduplication tables happens 'getTables', using 'Binary' utility
functions such as 'forwardGetRel'.

Here, a visualisation of the table structure we currently have (ignoring 'ExtensibleFields'):

┌──────────────┐
│   Headers    │
├──────────────┤
│   Ptr FS     ├────────┐
├──────────────┤        │
│   Ptr Name   ├─────┐  │
├──────────────┤     │  │
│              │     │  │
│   ModIface   │     │  │
│   Payload    │     │  │
│              │     │  │
├──────────────┤     │  │
│              │     │  │
│  Name Table  │◄────┘  │
│              │        │
├──────────────┤        │
│              │        │
│   FS Table   │◄───────┘
│              │
└──────────────┘

-}

{-
Note [Lazy ReaderUserData during IfaceType serialisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Serialising recursive data types, such as 'IfaceType', requires some trickery
to inject the deduplication table at the right moment.

When we serialise a value of 'IfaceType', we might encounter new 'IfaceType' values.
For example, 'IfaceAppTy' has an 'IfaceType' field, which we want to deduplicate as well.
Thus, when we serialise an 'IfaceType', we might add new 'IfaceType's to the 'GenericSymbolTable'
(i.e., the deduplication table). These 'IfaceType's are then subsequently also serialised to disk,
and uncover new 'IfaceType' values, etc...
In other words, when we serialise an 'IfaceType' we write it out using a post-order traversal.
See 'putGenericSymbolTable' for the implementation.

Now, when we deserialise the deduplication table, reading the first element of the deduplication table
will fail, as deserialisation requires that we read the child elements first. Remember, we wrote them to disk
using a post-order traversal.
To make this work, we therefore use 'lazyGet'' to lazily read the parent 'IfaceType', but delay the actual
deserialisation. We just assume that once you need to force a value, the deduplication table for 'IfaceType'
will be available.

That's where 'bhRef' comes into play:

@
    bhRef <- newIORef (error "used too soon")
    ud <- unsafeInterleaveIO (readIORef bhRef)
    ...
    ifaceTypeReaderTable <- initReadIfaceTypeTable ud
    ...
    writeIORef bhRef (getReaderUserData bhFinal)
@

'ud' is the 'ReaderUserData' that will eventually contain the deduplication table for 'IfaceType'.
As deserialisation of the 'IfaceType' needs the deduplication table, we provide a
promise that it will exist in the future (represented by @unsafeInterleaveIO (readIORef bhRef)@).
We pass 'ud' to 'initReadIfaceTypeTable', so the deserialisation will use the promised deduplication table.

Once we have "read" the deduplication table, it will be available in 'bhFinal', and we fulfill the promise
that the deduplication table for 'IfaceType' exists when forced.
-}

-- -----------------------------------------------------------------------------
-- The symbol table
--

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, -- The next index to use
        BinSymbolTable -> IORef (UniqFM Name (Int, Name))
bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
                                -- indexed by 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))
      -- It's OK to use nonDetEltsUFM here because the elements have
      -- indices that array uses to create order
    (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
    -- create an array of Names for the symbols and add them to the NameCache
    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)


-- Note [Symbol table representation of names]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- An occurrence of a name in an interface file is serialized as a single 32-bit
-- word. The format of this word is:
--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
--   A normal name. x is an index into the symbol table
--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
--   A known-key name. x is the Unique's Char, y is the int part. We assume that
--   all known-key uniques fit in this space. This is asserted by
--   GHC.Builtin.Utils.knownKeyNamesOkay.
--
-- During serialization we check for known-key things using isKnownKeyName.
-- During deserialization we use lookupKnownKeyName to get from the unique back
-- to its corresponding Name.


-- See Note [Symbol table representation of names]
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) -- INVARIANT: (ord c) fits in 8 bits
  = -- assert (u < 2^(22 :: Int))
    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
            -- massert (off < 2^(30 :: Int))
            writeFastMutInt symtab_next (off+1)
            writeIORef symtab_map_ref
                $! addToUFM symtab_map name (off,name)
            put_ bh (fromIntegral off :: Word32)

-- See Note [Symbol table representation of names]
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)