{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, BangPatterns #-}

--
--  (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,
        getSymtabName,
        getDictFastString,
        CheckHiWay(..),
        TraceBinIFace(..),
        getWithUserData,
        putWithUserData,

        -- * Internal serialisation functions
        getSymbolTable,
        putName,
        putDictionary,
        putFastString,
        putSymbolTable,
        BinSymbolTable(..),
        BinDictionary(..)
    ) where

import GHC.Prelude

import GHC.Tc.Utils.Monad
import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName )
import GHC.Unit
import GHC.Unit.Module.ModIface
import GHC.Types.Name
import GHC.Platform.Profile
import GHC.Types.Unique.FM
import GHC.Utils.Panic
import GHC.Utils.Binary as Binary
import GHC.Data.FastMutInt
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Types.Name.Cache
import GHC.Types.SrcLoc
import GHC.Platform
import GHC.Data.FastString
import GHC.Settings.Constants
import GHC.Utils.Fingerprint

import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
import Data.Char
import Data.Word
import Data.IORef
import Control.Monad

-- ---------------------------------------------------------------------------
-- 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

-- | 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, BinHandle)
readBinIfaceHeader :: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO (Fingerprint, BinHandle)
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
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 =
            -- 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (wanted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
wanted
                               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got "    String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
got String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
    BinHandle
bh <- String -> IO BinHandle
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)
    FixedLengthEncoding Word32
magic <- BinHandle -> IO (FixedLengthEncoding Word32)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    String
-> FixedLengthEncoding Word32
-> FixedLengthEncoding Word32
-> (FixedLengthEncoding Word32 -> SDoc)
-> IO ()
forall a. String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot String
"Magic" (Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic Platform
platform) FixedLengthEncoding Word32
magic (Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Word32 -> SDoc)
-> (FixedLengthEncoding Word32 -> Word32)
-> FixedLengthEncoding Word32
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixedLengthEncoding Word32 -> Word32
forall a. FixedLengthEncoding a -> a
unFixedLength)
    String -> Word32 -> Word32 -> IO ()
forall a. (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch String
"magic number mismatch: old/corrupt interface file?"
        (FixedLengthEncoding Word32 -> Word32
forall a. FixedLengthEncoding a -> a
unFixedLength (FixedLengthEncoding Word32 -> Word32)
-> FixedLengthEncoding Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic Platform
platform) (FixedLengthEncoding Word32 -> Word32
forall a. FixedLengthEncoding a -> a
unFixedLength FixedLengthEncoding Word32
magic)

    -- Check the interface file version and profile tag.
    String
check_ver  <- BinHandle -> IO String
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    let our_ver :: String
our_ver = Integer -> String
forall a. Show a => a -> String
show Integer
hiVersion
    String -> String -> String -> (String -> SDoc) -> IO ()
forall a. String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot String
"Version" String
our_ver String
check_ver String -> SDoc
text
    String -> String -> String -> IO ()
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 <- BinHandle -> IO String
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    let tag :: String
tag = Profile -> String
profileBuildTag Profile
profile
    String -> String -> String -> (String -> SDoc) -> IO ()
forall a. String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot String
"Way" String
tag String
check_tag String -> SDoc
forall a. Outputable a => a -> SDoc
ppr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CheckHiWay
checkHiWay CheckHiWay -> CheckHiWay -> Bool
forall a. Eq a => a -> a -> Bool
== CheckHiWay
CheckHiWay) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> String -> String -> IO ()
forall a. (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch String
"mismatched interface file profile tag" String
tag String
check_tag

    Fingerprint
src_hash <- BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    (Fingerprint, BinHandle) -> IO (Fingerprint, BinHandle)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fingerprint
src_hash, BinHandle
bh)

-- | Read an interface file.
readBinIface
  :: Profile
  -> NameCache
  -> CheckHiWay
  -> TraceBinIFace
  -> FilePath
  -> IO ModIface
readBinIface :: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO ModIface
readBinIface Profile
profile NameCache
name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIface String
hi_path = do
    (Fingerprint
src_hash, BinHandle
bh) <- Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO (Fingerprint, BinHandle)
readBinIfaceHeader Profile
profile NameCache
name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIface String
hi_path

    Bin Any
extFields_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

    ModIface
mod_iface <- NameCache -> BinHandle -> IO ModIface
forall a. Binary a => NameCache -> BinHandle -> IO a
getWithUserData NameCache
name_cache BinHandle
bh

    BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
extFields_p
    ExtensibleFields
extFields <- BinHandle -> IO ExtensibleFields
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

    ModIface -> IO ModIface
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModIface
mod_iface
      { mi_ext_fields :: ExtensibleFields
mi_ext_fields = ExtensibleFields
extFields
      , mi_src_hash :: Fingerprint
mi_src_hash = Fingerprint
src_hash
      }

-- | 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 -> BinHandle -> IO a
getWithUserData :: forall a. Binary a => NameCache -> BinHandle -> IO a
getWithUserData NameCache
name_cache BinHandle
bh = do
    -- Read the dictionary
    -- The next word in the file is a pointer to where the dictionary is
    -- (probably at the end of the file)
    Bin Any
dict_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh
    Bin Any
data_p <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh          -- Remember where we are now
    BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p
    Dictionary
dict   <- BinHandle -> IO Dictionary
getDictionary BinHandle
bh
    BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
data_p             -- Back to where we were before

    -- Initialise the user-data field of bh
    BinHandle
bh <- do
        BinHandle
bh <- BinHandle -> IO BinHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinHandle -> IO BinHandle) -> BinHandle -> IO BinHandle
forall a b. (a -> b) -> a -> b
$ BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (String -> BinHandle -> IO Name
forall a. HasCallStack => String -> a
error String
"getSymtabName")
                                                     (Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
        Bin Any
symtab_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh     -- Get the symtab ptr
        Bin Any
data_p <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh          -- Remember where we are now
        BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
symtab_p
        SymbolTable
symtab <- BinHandle -> NameCache -> IO SymbolTable
getSymbolTable BinHandle
bh NameCache
name_cache
        BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
data_p             -- Back to where we were before

        -- It is only now that we know how to get a Name
        BinHandle -> IO BinHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinHandle -> IO BinHandle) -> BinHandle -> IO BinHandle
forall a b. (a -> b) -> a -> b
$ BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (NameCache -> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName NameCache
name_cache Dictionary
dict SymbolTable
symtab)
                                               (Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)

    -- Read the interface file
    BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

-- | Write an interface file
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
    BinHandle -> FixedLengthEncoding Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic Platform
platform)

    -- The version, profile tag, and source hash go next
    BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Integer -> String
forall a. Show a => a -> String
show Integer
hiVersion)
    let tag :: String
tag = Profile -> String
profileBuildTag Profile
profile
    BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_  BinHandle
bh String
tag
    BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_  BinHandle
bh (ModIface -> Fingerprint
forall (phase :: ModIfacePhase). ModIface_ phase -> Fingerprint
mi_src_hash ModIface
mod_iface)

    Bin (Bin Any)
extFields_p_p <- BinHandle -> IO (Bin (Bin Any))
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
extFields_p_p

    TraceBinIFace -> BinHandle -> ModIface -> IO ()
forall a. Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData TraceBinIFace
traceBinIface BinHandle
bh ModIface
mod_iface

    Bin Any
extFields_p <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
extFields_p_p Bin Any
extFields_p
    BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
extFields_p
    BinHandle -> ExtensibleFields -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (ModIface -> ExtensibleFields
forall (phase :: ModIfacePhase).
ModIface_ phase -> ExtensibleFields
mi_ext_fields ModIface
mod_iface)

    -- And send the result to the file
    BinHandle -> String -> IO ()
writeBinMem BinHandle
bh String
hi_path

-- | 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 -> BinHandle -> a -> IO ()
putWithUserData :: forall a. Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData TraceBinIFace
traceBinIface BinHandle
bh a
payload = do
    -- Remember where the dictionary pointer will go
    Bin (Bin Any)
dict_p_p <- BinHandle -> IO (Bin (Bin Any))
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    -- Placeholder for ptr to dictionary
    BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
dict_p_p

    -- Remember where the symbol table pointer will go
    Bin (Bin Any)
symtab_p_p <- BinHandle -> IO (Bin (Bin Any))
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
symtab_p_p
    -- Make some initial state
    FastMutInt
symtab_next <- Int -> IO FastMutInt
newFastMutInt Int
0
    IORef (UniqFM Name (Int, Name))
symtab_map <- UniqFM Name (Int, Name) -> IO (IORef (UniqFM Name (Int, Name)))
forall a. a -> IO (IORef a)
newIORef UniqFM Name (Int, Name)
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 <- UniqFM FastString (Int, FastString)
-> IO (IORef (UniqFM FastString (Int, FastString)))
forall a. a -> IO (IORef a)
newIORef UniqFM FastString (Int, FastString)
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 }

    -- Put the main thing,
    BinHandle
bh <- BinHandle -> IO BinHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinHandle -> IO BinHandle) -> BinHandle -> IO BinHandle
forall a b. (a -> b) -> a -> b
$ BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (UserData -> BinHandle) -> UserData -> BinHandle
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)
    BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
payload

    -- Write the symtab pointer at the front of the file
    Bin Any
symtab_p <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh        -- This is where the symtab will start
    BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
symtab_p_p Bin Any
symtab_p  -- Fill in the placeholder
    BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
symtab_p           -- Seek back to the end of the file

    -- Write the symbol table itself
    Int
symtab_next <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
    UniqFM Name (Int, Name)
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
    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         -> () -> IO ()
forall a. a -> IO a
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")

    -- NB. write the dictionary after the symbol table, because
    -- writing the symbol table may create more dictionary entries.

    -- Write the dictionary pointer at the front of the file
    Bin Any
dict_p <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh          -- This is where the dictionary will start
    BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
dict_p_p Bin Any
dict_p      -- Fill in the placeholder
    BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p             -- Seek back to the end of the file

    -- Write the dictionary itself
    Int
dict_next <- FastMutInt -> IO Int
readFastMutInt FastMutInt
dict_next_ref
    UniqFM FastString (Int, FastString)
dict_map  <- IORef (UniqFM FastString (Int, FastString))
-> IO (UniqFM FastString (Int, FastString))
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         -> () -> IO ()
forall a. a -> IO a
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")



-- | 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


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

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
    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
next_off
    let names :: [Name]
names = SymbolTable -> [Name]
forall i e. Array i e -> [e]
elems ((Int, Int) -> [(Int, Name)] -> SymbolTable
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,Int
next_offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (UniqFM Name (Int, Name) -> [(Int, Name)]
forall key 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 -> BinHandle -> Name -> UniqFM Name (Int, Name) -> IO ()
forall key. BinHandle -> Name -> UniqFM key (Int, Name) -> IO ()
serialiseName BinHandle
bh Name
n UniqFM Name (Int, Name)
symtab) [Name]
names


getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable BinHandle
bh NameCache
name_cache = do
    Int
sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
    -- create an array of Names for the symbols and add them to the NameCache
    NameCache
-> (OrigNameCache -> IO (OrigNameCache, SymbolTable))
-> IO SymbolTable
forall c.
NameCache -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
updateNameCache' NameCache
name_cache ((OrigNameCache -> IO (OrigNameCache, SymbolTable))
 -> IO SymbolTable)
-> (OrigNameCache -> IO (OrigNameCache, SymbolTable))
-> IO SymbolTable
forall a b. (a -> b) -> a -> b
$ \OrigNameCache
cache0 -> do
        IOArray Int Name
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)
        OrigNameCache
cache <- Word
-> BinHandle
-> OrigNameCache
-> (Word
    -> (Unit, ModuleName, OccName)
    -> OrigNameCache
    -> IO OrigNameCache)
-> IO OrigNameCache
forall a b.
Binary a =>
Word -> BinHandle -> b -> (Word -> a -> b -> IO b) -> IO b
foldGet (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz) BinHandle
bh OrigNameCache
cache0 ((Word
  -> (Unit, ModuleName, OccName)
  -> OrigNameCache
  -> IO OrigNameCache)
 -> IO OrigNameCache)
-> (Word
    -> (Unit, ModuleName, OccName)
    -> OrigNameCache
    -> IO OrigNameCache)
-> IO OrigNameCache
forall a b. (a -> b) -> a -> b
$ \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
              Unique
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
name_cache
              let name :: Name
name      = Unique -> GenModule Unit -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq GenModule Unit
mod OccName
occ SrcSpan
noSrcSpan
                  new_cache :: OrigNameCache
new_cache = OrigNameCache -> GenModule Unit -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache GenModule Unit
mod OccName
occ Name
name
              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
new_cache
        SymbolTable
arr <- IOArray Int Name -> IO SymbolTable
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze IOArray Int Name
mut_arr
        (OrigNameCache, SymbolTable) -> IO (OrigNameCache, SymbolTable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrigNameCache
cache, SymbolTable
arr)

serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName :: forall key. BinHandle -> Name -> UniqFM key (Int, Name) -> IO ()
serialiseName BinHandle
bh Name
name UniqFM key (Int, Name)
_ = do
    let mod :: GenModule Unit
mod = 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) ((() :: Constraint) => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
name)
    BinHandle -> (Unit, ModuleName, OccName) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
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 :: 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) -- INVARIANT: (ord c) fits in 8 bits
  = -- assert (u < 2^(22 :: Int))
    BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
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
.|. (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u :: Word32))

  | Bool
otherwise
  = do UniqFM Name (Int, Name)
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 UniqFM Name (Int, Name) -> Name -> Maybe (Int, Name)
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
_) -> BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
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
            -- massert (off < 2^(30 :: Int))
            FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
symtab_next (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            IORef (UniqFM Name (Int, Name)) -> UniqFM Name (Int, Name) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM Name (Int, Name))
symtab_map_ref
                (UniqFM Name (Int, Name) -> IO ())
-> UniqFM Name (Int, Name) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM Name (Int, Name)
-> Name -> (Int, Name) -> UniqFM Name (Int, Name)
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)
            BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)

-- See Note [Symbol table representation of names]
getSymtabName :: NameCache
              -> Dictionary -> SymbolTable
              -> BinHandle -> IO Name
getSymtabName :: NameCache -> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName NameCache
_name_cache Dictionary
_dict SymbolTable
symtab BinHandle
bh = do
    Word32
i :: Word32 <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    case Word32
i Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
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
symtab SymbolTable -> 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 :: Int
ix  = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x003FFFFF
          u :: Unique
u   = Char -> Int -> Unique
mkUnique Char
tag Int
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
$$ (Char, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Unique -> (Char, Int)
unpkUnique Unique
u))
                      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)

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
  }

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 IO Word32 -> (Word32 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BinHandle -> Word32 -> IO ()
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 <- IORef (UniqFM FastString (Int, FastString))
-> IO (UniqFM FastString (Int, FastString))
forall a. IORef a -> IO a
readIORef IORef (UniqFM FastString (Int, FastString))
out_r
    let !uniq :: Unique
uniq = FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
f
    case UniqFM FastString (Int, FastString)
-> Unique -> Maybe (Int, FastString)
forall key elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly UniqFM FastString (Int, FastString)
out Unique
uniq of
        Just (Int
j, FastString
_)  -> Word32 -> IO Word32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word32
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
           IORef (UniqFM FastString (Int, FastString))
-> UniqFM FastString (Int, FastString) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM FastString (Int, FastString))
out_r (UniqFM FastString (Int, FastString) -> IO ())
-> UniqFM FastString (Int, FastString) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM FastString (Int, FastString)
-> Unique
-> (Int, FastString)
-> UniqFM FastString (Int, FastString)
forall key elt. UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly UniqFM FastString (Int, FastString)
out Unique
uniq (Int
j, FastString
f)
           Word32 -> IO Word32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word32
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 <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    FastString -> IO FastString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> IO FastString) -> FastString -> IO FastString
forall a b. (a -> b) -> a -> b
$! (Dictionary
dict Dictionary -> Int -> FastString
forall i e. Ix i => Array i e -> i -> e
! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
j :: Word32))

data BinDictionary = BinDictionary {
        BinDictionary -> FastMutInt
bin_dict_next :: !FastMutInt, -- The next index to use
        BinDictionary -> IORef (UniqFM FastString (Int, FastString))
bin_dict_map  :: !(IORef (UniqFM FastString (Int,FastString)))
                                -- indexed by FastString
  }