{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MagicHash #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module GHC.ByteCode.Binary (
  -- * ByteCode objects on disk and intermediate representations
  OnDiskModuleByteCode(..),
  BytecodeLibX(..),
  BytecodeLib,
  OnDiskBytecodeLib,
  InterpreterLibrary(..),
  InterpreterLibraryContents(..),
  -- * Binary 'Name' serializers
  BytecodeNameEnv(..),
  addBinNameWriter,
  addBinNameReader,
) where

import GHC.Prelude

import GHC.ByteCode.Types
import GHC.Data.FastString
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Unit.Types
import GHC.Utils.Binary
import GHC.Utils.Exception
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Utils.Fingerprint (Fingerprint)

import Control.Monad
import Data.ByteString (ByteString)
import Data.ByteString.Short (ShortByteString(..))
import Data.Foldable
import Data.IORef
import Data.Proxy
import Data.Word
import System.IO.Unsafe (unsafeInterleaveIO)

-- | The on-disk representation of a bytecode object for a specific module.
--
-- This is the representation which we serialise and write to disk.
-- The difference from 'ModuleByteCode' is that the contents of the object files
-- contained by 'ModuleByteCode' are stored in-memory rather than as file paths to
-- temporary files.
data OnDiskModuleByteCode = OnDiskModuleByteCode { OnDiskModuleByteCode -> Module
odgbc_module :: Module
                                                 , OnDiskModuleByteCode -> Fingerprint
odgbc_hash :: Fingerprint
                                                 , OnDiskModuleByteCode -> CompiledByteCode
odgbc_compiled_byte_code :: CompiledByteCode
                                                 , OnDiskModuleByteCode -> [ByteString]
odgbc_foreign :: [ByteString]  -- ^ Contents of object files
                                                 }

type OnDiskBytecodeLib = BytecodeLibX (Maybe InterpreterLibraryContents)

instance Outputable a => Outputable (BytecodeLibX a) where
  ppr :: BytecodeLibX a -> SDoc
ppr (BytecodeLib {a
[CompiledByteCode]
UnitId
bytecodeLibUnitId :: UnitId
bytecodeLibFiles :: [CompiledByteCode]
bytecodeLibForeign :: a
bytecodeLibForeign :: forall a. BytecodeLibX a -> a
bytecodeLibFiles :: forall a. BytecodeLibX a -> [CompiledByteCode]
bytecodeLibUnitId :: forall a. BytecodeLibX a -> UnitId
..}) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"BytecodeLib" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
bytecodeLibUnitId),
    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Files" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CompiledByteCode] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CompiledByteCode]
bytecodeLibFiles),
    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Foreign" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
bytecodeLibForeign) ]

type BytecodeLib = BytecodeLibX (Maybe InterpreterLibrary)

-- | A bytecode library is a collection of CompiledByteCode objects and a .so file containing the combination of foreign stubs
data BytecodeLibX a = BytecodeLib {
    forall a. BytecodeLibX a -> UnitId
bytecodeLibUnitId :: UnitId,
    forall a. BytecodeLibX a -> [CompiledByteCode]
bytecodeLibFiles :: [CompiledByteCode],
    forall a. BytecodeLibX a -> a
bytecodeLibForeign :: a -- A library file containing the combination of foreign stubs. (Ie arising from CApiFFI)
}

data InterpreterLibrary = InterpreterSharedObject { InterpreterLibrary -> String
getSharedObjectFilePath :: FilePath, InterpreterLibrary -> String
getSharedObjectDir :: FilePath, InterpreterLibrary -> String
getSharedObjectLibName :: String }
                         | InterpreterStaticObjects { InterpreterLibrary -> [String]
getStaticObjects :: [FilePath] }


instance Outputable InterpreterLibrary where
  ppr :: InterpreterLibrary -> SDoc
ppr (InterpreterSharedObject String
path String
dir String
name) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SharedObject" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
path SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
dir SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
name
  ppr (InterpreterStaticObjects [String]
paths) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StaticObjects" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text ([String] -> String
forall a. Show a => a -> String
show [String]
paths)


data InterpreterLibraryContents = InterpreterLibrarySharedContents { InterpreterLibraryContents -> ByteString
interpreterLibraryContents :: ByteString }
                                | InterpreterLibraryStaticContents { InterpreterLibraryContents -> [ByteString]
interpreterLibraryStaticContents :: [ByteString] }

instance Binary InterpreterLibraryContents where
  get :: ReadBinHandle -> IO InterpreterLibraryContents
get ReadBinHandle
bh = do
    t <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
    case t of
      Word8
0 -> ByteString -> InterpreterLibraryContents
ByteString -> InterpreterLibraryContents
InterpreterLibrarySharedContents (ByteString -> InterpreterLibraryContents)
-> IO ByteString -> IO InterpreterLibraryContents
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO ByteString
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
1 -> [ByteString] -> InterpreterLibraryContents
[ByteString] -> InterpreterLibraryContents
InterpreterLibraryStaticContents ([ByteString] -> InterpreterLibraryContents)
-> IO [ByteString] -> IO InterpreterLibraryContents
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO [ByteString]
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
_ -> String -> IO InterpreterLibraryContents
forall a. HasCallStack => String -> a
panic String
"Binary InterpreterLibraryContents: invalid byte"
  put_ :: WriteBinHandle -> InterpreterLibraryContents -> IO ()
put_ WriteBinHandle
bh (InterpreterLibrarySharedContents ByteString
contents) = do
    WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0
    WriteBinHandle -> ByteString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh ByteString
contents
  put_ WriteBinHandle
bh (InterpreterLibraryStaticContents [ByteString]
contents) = do
    WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1
    WriteBinHandle -> [ByteString] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [ByteString]
contents

instance Binary OnDiskModuleByteCode where
  get :: ReadBinHandle -> IO OnDiskModuleByteCode
get ReadBinHandle
bh = do
    odgbc_hash <- ReadBinHandle -> IO Fingerprint
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
    odgbc_module <- get bh
    odgbc_compiled_byte_code <- lazyGet bh
    odgbc_foreign <- lazyGet bh
    pure OnDiskModuleByteCode {..}

  put_ :: WriteBinHandle -> OnDiskModuleByteCode -> IO ()
put_ WriteBinHandle
bh OnDiskModuleByteCode {[ByteString]
Fingerprint
Module
CompiledByteCode
odgbc_module :: OnDiskModuleByteCode -> Module
odgbc_hash :: OnDiskModuleByteCode -> Fingerprint
odgbc_compiled_byte_code :: OnDiskModuleByteCode -> CompiledByteCode
odgbc_foreign :: OnDiskModuleByteCode -> [ByteString]
odgbc_module :: Module
odgbc_hash :: Fingerprint
odgbc_compiled_byte_code :: CompiledByteCode
odgbc_foreign :: [ByteString]
..} = do
    WriteBinHandle -> Fingerprint -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Fingerprint
odgbc_hash
    WriteBinHandle -> Module -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Module
odgbc_module
    WriteBinHandle -> CompiledByteCode -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
lazyPut WriteBinHandle
bh CompiledByteCode
odgbc_compiled_byte_code
    WriteBinHandle -> [ByteString] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
lazyPut WriteBinHandle
bh [ByteString]
odgbc_foreign

instance Binary OnDiskBytecodeLib where
  get :: ReadBinHandle -> IO OnDiskBytecodeLib
get ReadBinHandle
bh = do
    bytecodeLibUnitId <- ReadBinHandle -> IO UnitId
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
    bytecodeLibFiles <- get bh
    bytecodeLibForeign <- get bh
    pure BytecodeLib {..}

  put_ :: WriteBinHandle -> OnDiskBytecodeLib -> IO ()
put_ WriteBinHandle
bh BytecodeLib {[CompiledByteCode]
Maybe InterpreterLibraryContents
UnitId
bytecodeLibForeign :: forall a. BytecodeLibX a -> a
bytecodeLibFiles :: forall a. BytecodeLibX a -> [CompiledByteCode]
bytecodeLibUnitId :: forall a. BytecodeLibX a -> UnitId
bytecodeLibUnitId :: UnitId
bytecodeLibFiles :: [CompiledByteCode]
bytecodeLibForeign :: Maybe InterpreterLibraryContents
..} = do
    WriteBinHandle -> UnitId -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh UnitId
bytecodeLibUnitId
    WriteBinHandle -> [CompiledByteCode] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [CompiledByteCode]
bytecodeLibFiles
    WriteBinHandle -> Maybe InterpreterLibraryContents -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Maybe InterpreterLibraryContents
bytecodeLibForeign

instance Binary CompiledByteCode where
  get :: ReadBinHandle -> IO CompiledByteCode
get ReadBinHandle
bh = do
    bc_bcos <- ReadBinHandle -> IO (FlatBag UnlinkedBCO)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
    bc_itbls_len <- get bh
    bc_itbls <- replicateM bc_itbls_len $ do
      nm <- getViaBinName bh
      itbl <- get bh
      pure (nm, itbl)
    bc_strs_len <- get bh
    bc_strs <-
      replicateM bc_strs_len $ (,) <$> getViaBinName bh <*> get bh
    bc_breaks <- get bh
    bc_spt_entries <- get bh
    return $
      CompiledByteCode
        { bc_bcos,
          bc_itbls,
          bc_strs,
          bc_breaks,
          bc_spt_entries
        }

  put_ :: WriteBinHandle -> CompiledByteCode -> IO ()
put_ WriteBinHandle
bh CompiledByteCode {[(Name, ByteString)]
[(Name, ConInfoTable)]
[SptEntry]
Maybe InternalModBreaks
FlatBag UnlinkedBCO
bc_bcos :: CompiledByteCode -> FlatBag UnlinkedBCO
bc_itbls :: CompiledByteCode -> [(Name, ConInfoTable)]
bc_strs :: CompiledByteCode -> [(Name, ByteString)]
bc_breaks :: CompiledByteCode -> Maybe InternalModBreaks
bc_spt_entries :: CompiledByteCode -> [SptEntry]
bc_bcos :: FlatBag UnlinkedBCO
bc_itbls :: [(Name, ConInfoTable)]
bc_strs :: [(Name, ByteString)]
bc_breaks :: Maybe InternalModBreaks
bc_spt_entries :: [SptEntry]
..} = do
    WriteBinHandle -> FlatBag UnlinkedBCO -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FlatBag UnlinkedBCO
bc_bcos
    WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Name, ConInfoTable)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, ConInfoTable)]
bc_itbls
    [(Name, ConInfoTable)] -> ((Name, ConInfoTable) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Name, ConInfoTable)]
bc_itbls (((Name, ConInfoTable) -> IO ()) -> IO ())
-> ((Name, ConInfoTable) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Name
nm, ConInfoTable
itbl) -> do
      WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
nm
      WriteBinHandle -> ConInfoTable -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh ConInfoTable
itbl
    WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ [(Name, ByteString)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, ByteString)]
bc_strs
    [(Name, ByteString)] -> ((Name, ByteString) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Name, ByteString)]
bc_strs (((Name, ByteString) -> IO ()) -> IO ())
-> ((Name, ByteString) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Name
nm, ByteString
str) -> WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
nm IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> ByteString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh ByteString
str
    WriteBinHandle -> Maybe InternalModBreaks -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Maybe InternalModBreaks
bc_breaks
    WriteBinHandle -> [SptEntry] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [SptEntry]
bc_spt_entries

instance Binary UnlinkedBCO where
  get :: ReadBinHandle -> IO UnlinkedBCO
get ReadBinHandle
bh = do
    t <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
    case t of
      Word8
0 -> Name
-> Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> FlatBag BCONPtr
-> FlatBag BCOPtr
-> UnlinkedBCO
Name
-> Int
-> BCOByteArray Word16
-> BCOByteArray Word
-> FlatBag BCONPtr
-> FlatBag BCOPtr
-> UnlinkedBCO
UnlinkedBCO
        (Name
 -> Int
 -> BCOByteArray Word16
 -> BCOByteArray Word
 -> FlatBag BCONPtr
 -> FlatBag BCOPtr
 -> UnlinkedBCO)
-> IO Name
-> IO
     (Int
      -> BCOByteArray Word16
      -> BCOByteArray Word
      -> FlatBag BCONPtr
      -> FlatBag BCOPtr
      -> UnlinkedBCO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Name
getViaBinName ReadBinHandle
bh
        IO
  (Int
   -> BCOByteArray Word16
   -> BCOByteArray Word
   -> FlatBag BCONPtr
   -> FlatBag BCOPtr
   -> UnlinkedBCO)
-> IO Int
-> IO
     (BCOByteArray Word16
      -> BCOByteArray Word
      -> FlatBag BCONPtr
      -> FlatBag BCOPtr
      -> UnlinkedBCO)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO Int
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        IO
  (BCOByteArray Word16
   -> BCOByteArray Word
   -> FlatBag BCONPtr
   -> FlatBag BCOPtr
   -> UnlinkedBCO)
-> IO (BCOByteArray Word16)
-> IO
     (BCOByteArray Word
      -> FlatBag BCONPtr -> FlatBag BCOPtr -> UnlinkedBCO)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO (BCOByteArray Word16)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        IO
  (BCOByteArray Word
   -> FlatBag BCONPtr -> FlatBag BCOPtr -> UnlinkedBCO)
-> IO (BCOByteArray Word)
-> IO (FlatBag BCONPtr -> FlatBag BCOPtr -> UnlinkedBCO)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO (BCOByteArray Word)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        IO (FlatBag BCONPtr -> FlatBag BCOPtr -> UnlinkedBCO)
-> IO (FlatBag BCONPtr) -> IO (FlatBag BCOPtr -> UnlinkedBCO)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO (FlatBag BCONPtr)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        IO (FlatBag BCOPtr -> UnlinkedBCO)
-> IO (FlatBag BCOPtr) -> IO UnlinkedBCO
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO (FlatBag BCOPtr)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
1 -> Name
-> Name -> FlatBag BCONPtr -> FlatBag BCOPtr -> Bool -> UnlinkedBCO
Name
-> Name -> FlatBag BCONPtr -> FlatBag BCOPtr -> Bool -> UnlinkedBCO
UnlinkedStaticCon
        (Name
 -> Name
 -> FlatBag BCONPtr
 -> FlatBag BCOPtr
 -> Bool
 -> UnlinkedBCO)
-> IO Name
-> IO
     (Name -> FlatBag BCONPtr -> FlatBag BCOPtr -> Bool -> UnlinkedBCO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Name
getViaBinName ReadBinHandle
bh
        IO
  (Name -> FlatBag BCONPtr -> FlatBag BCOPtr -> Bool -> UnlinkedBCO)
-> IO Name
-> IO (FlatBag BCONPtr -> FlatBag BCOPtr -> Bool -> UnlinkedBCO)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO Name
getViaBinName ReadBinHandle
bh
        IO (FlatBag BCONPtr -> FlatBag BCOPtr -> Bool -> UnlinkedBCO)
-> IO (FlatBag BCONPtr)
-> IO (FlatBag BCOPtr -> Bool -> UnlinkedBCO)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO (FlatBag BCONPtr)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        IO (FlatBag BCOPtr -> Bool -> UnlinkedBCO)
-> IO (FlatBag BCOPtr) -> IO (Bool -> UnlinkedBCO)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO (FlatBag BCOPtr)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        IO (Bool -> UnlinkedBCO) -> IO Bool -> IO UnlinkedBCO
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadBinHandle -> IO Bool
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
_ -> String -> IO UnlinkedBCO
forall a. HasCallStack => String -> a
panic String
"Binary UnlinkedBCO: invalid byte"

  put_ :: WriteBinHandle -> UnlinkedBCO -> IO ()
put_ WriteBinHandle
bh UnlinkedBCO {Int
BCOByteArray Word
BCOByteArray Word16
Name
FlatBag BCONPtr
FlatBag BCOPtr
unlinkedBCOName :: Name
unlinkedBCOArity :: Int
unlinkedBCOInstrs :: BCOByteArray Word16
unlinkedBCOBitmap :: BCOByteArray Word
unlinkedBCOLits :: FlatBag BCONPtr
unlinkedBCOPtrs :: FlatBag BCOPtr
unlinkedBCOPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedBCOLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedBCOBitmap :: UnlinkedBCO -> BCOByteArray Word
unlinkedBCOInstrs :: UnlinkedBCO -> BCOByteArray Word16
unlinkedBCOArity :: UnlinkedBCO -> Int
unlinkedBCOName :: UnlinkedBCO -> Name
..} = do
    WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0
    WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
unlinkedBCOName
    WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Int
unlinkedBCOArity
    WriteBinHandle -> BCOByteArray Word16 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh BCOByteArray Word16
unlinkedBCOInstrs
    WriteBinHandle -> BCOByteArray Word -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh BCOByteArray Word
unlinkedBCOBitmap
    WriteBinHandle -> FlatBag BCONPtr -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FlatBag BCONPtr
unlinkedBCOLits
    WriteBinHandle -> FlatBag BCOPtr -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FlatBag BCOPtr
unlinkedBCOPtrs
  put_ WriteBinHandle
bh UnlinkedStaticCon {Bool
Name
FlatBag BCONPtr
FlatBag BCOPtr
unlinkedStaticConName :: Name
unlinkedStaticConDataConName :: Name
unlinkedStaticConLits :: FlatBag BCONPtr
unlinkedStaticConPtrs :: FlatBag BCOPtr
unlinkedStaticConIsUnlifted :: Bool
unlinkedStaticConIsUnlifted :: UnlinkedBCO -> Bool
unlinkedStaticConPtrs :: UnlinkedBCO -> FlatBag BCOPtr
unlinkedStaticConLits :: UnlinkedBCO -> FlatBag BCONPtr
unlinkedStaticConDataConName :: UnlinkedBCO -> Name
unlinkedStaticConName :: UnlinkedBCO -> Name
..} = do
    WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1
    WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
unlinkedStaticConName
    WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
unlinkedStaticConDataConName
    WriteBinHandle -> FlatBag BCONPtr -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FlatBag BCONPtr
unlinkedStaticConLits
    WriteBinHandle -> FlatBag BCOPtr -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FlatBag BCOPtr
unlinkedStaticConPtrs
    WriteBinHandle -> Bool -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Bool
unlinkedStaticConIsUnlifted

-- Also see Note [BCOByteArray serialization]. This instance is unlike
-- the `Binary` instances in `ghci`, which are for the `Binary` class
-- in `binary` and are used across host/target platforms; here this
-- instance is only used on the host for bytecode object serialization
-- and doesn't cross host/target boundary. Therefore it's safe to
-- serialize the underlying buffer directly.
instance Binary (BCOByteArray a) where
  put_ :: WriteBinHandle -> BCOByteArray a -> IO ()
put_ WriteBinHandle
bh (BCOByteArray ByteArray#
ba#) = WriteBinHandle -> ShortByteString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (ShortByteString -> IO ()) -> ShortByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteArray# -> ShortByteString
SBS ByteArray#
ba#

  get :: ReadBinHandle -> IO (BCOByteArray a)
get ReadBinHandle
bh = (\(SBS ByteArray#
ba#) -> ByteArray# -> BCOByteArray a
forall a. ByteArray# -> BCOByteArray a
BCOByteArray ByteArray#
ba#) (ShortByteString -> BCOByteArray a)
-> IO ShortByteString -> IO (BCOByteArray a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO ShortByteString
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh

instance Binary BCOPtr where
  get :: ReadBinHandle -> IO BCOPtr
get ReadBinHandle
bh = do
    t <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
    case t of
      Word8
0 -> Name -> BCOPtr
Name -> BCOPtr
BCOPtrName (Name -> BCOPtr) -> IO Name -> IO BCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Name
getViaBinName ReadBinHandle
bh
      Word8
1 -> PrimOp -> BCOPtr
PrimOp -> BCOPtr
BCOPtrPrimOp (PrimOp -> BCOPtr) -> IO PrimOp -> IO BCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO PrimOp
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
2 -> UnlinkedBCO -> BCOPtr
UnlinkedBCO -> BCOPtr
BCOPtrBCO (UnlinkedBCO -> BCOPtr) -> IO UnlinkedBCO -> IO BCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO UnlinkedBCO
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
3 -> Module -> BCOPtr
Module -> BCOPtr
BCOPtrBreakArray (Module -> BCOPtr) -> IO Module -> IO BCOPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Module
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
_ -> String -> IO BCOPtr
forall a. HasCallStack => String -> a
panic String
"Binary BCOPtr: invalid byte"

  put_ :: WriteBinHandle -> BCOPtr -> IO ()
put_ WriteBinHandle
bh BCOPtr
ptr = case BCOPtr
ptr of
    BCOPtrName Name
nm -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
nm
    BCOPtrPrimOp PrimOp
op -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> PrimOp -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh PrimOp
op
    BCOPtrBCO UnlinkedBCO
bco -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
2 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> UnlinkedBCO -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh UnlinkedBCO
bco
    BCOPtrBreakArray Module
info_mod -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
3 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> Module -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Module
info_mod

instance Binary BCONPtr where
  get :: ReadBinHandle -> IO BCONPtr
get ReadBinHandle
bh = do
    t <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
    case t of
      Word8
0 -> Word -> BCONPtr
Word -> BCONPtr
BCONPtrWord (Word -> BCONPtr) -> (Word64 -> Word) -> Word64 -> BCONPtr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> BCONPtr) -> IO Word64 -> IO BCONPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadBinHandle -> IO Word64
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh :: IO Word64)
      Word8
1 -> FastString -> BCONPtr
FastString -> BCONPtr
BCONPtrLbl (FastString -> BCONPtr) -> IO FastString -> IO BCONPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO FastString
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
2 -> Name -> BCONPtr
Name -> BCONPtr
BCONPtrItbl (Name -> BCONPtr) -> IO Name -> IO BCONPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Name
getViaBinName ReadBinHandle
bh
      Word8
3 -> Name -> BCONPtr
Name -> BCONPtr
BCONPtrAddr (Name -> BCONPtr) -> IO Name -> IO BCONPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO Name
getViaBinName ReadBinHandle
bh
      Word8
4 -> ByteString -> BCONPtr
ByteString -> BCONPtr
BCONPtrStr (ByteString -> BCONPtr) -> IO ByteString -> IO BCONPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO ByteString
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
5 -> FastString -> BCONPtr
FastString -> BCONPtr
BCONPtrFS (FastString -> BCONPtr) -> IO FastString -> IO BCONPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO FastString
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
6 -> FFIInfo -> BCONPtr
FFIInfo -> BCONPtr
BCONPtrFFIInfo (FFIInfo -> BCONPtr) -> IO FFIInfo -> IO BCONPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO FFIInfo
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
7 -> InternalBreakpointId -> BCONPtr
InternalBreakpointId -> BCONPtr
BCONPtrCostCentre (InternalBreakpointId -> BCONPtr)
-> IO InternalBreakpointId -> IO BCONPtr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO InternalBreakpointId
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
      Word8
_ -> String -> IO BCONPtr
forall a. HasCallStack => String -> a
panic String
"Binary BCONPtr: invalid byte"

  put_ :: WriteBinHandle -> BCONPtr -> IO ()
put_ WriteBinHandle
bh BCONPtr
ptr = case BCONPtr
ptr of
    BCONPtrWord Word
lit -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> Word64 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
lit :: Word64)
    BCONPtrLbl FastString
sym -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> FastString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FastString
sym
    BCONPtrItbl Name
nm -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
2 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
nm
    BCONPtrAddr Name
nm -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
3 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
nm
    BCONPtrStr ByteString
str -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
4 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> ByteString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh ByteString
str
    BCONPtrFS FastString
fs -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
5 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> FastString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FastString
fs
    BCONPtrFFIInfo FFIInfo
ffi -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
6 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> FFIInfo -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FFIInfo
ffi
    BCONPtrCostCentre InternalBreakpointId
ibi -> WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
7 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriteBinHandle -> InternalBreakpointId -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh InternalBreakpointId
ibi

newtype BinName = BinName {BinName -> Name
unBinName :: Name}

getViaBinName :: ReadBinHandle -> IO Name
getViaBinName :: ReadBinHandle -> IO Name
getViaBinName ReadBinHandle
bh = case Proxy BinName -> ReadBinHandle -> BinaryReader BinName
forall a. Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a
findUserDataReader Proxy BinName
forall {k} (t :: k). Proxy t
Proxy ReadBinHandle
bh of
  BinaryReader ReadBinHandle -> IO BinName
f -> BinName -> Name
unBinName (BinName -> Name) -> IO BinName -> IO Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO BinName
f ReadBinHandle
bh

putViaBinName :: WriteBinHandle -> Name -> IO ()
putViaBinName :: WriteBinHandle -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
nm = case Proxy BinName -> WriteBinHandle -> BinaryWriter BinName
forall a. Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a
findUserDataWriter Proxy BinName
forall {k} (t :: k). Proxy t
Proxy WriteBinHandle
bh of
  BinaryWriter WriteBinHandle -> BinName -> IO ()
f -> WriteBinHandle -> BinName -> IO ()
f WriteBinHandle
bh (BinName -> IO ()) -> BinName -> IO ()
forall a b. (a -> b) -> a -> b
$ Name -> BinName
BinName Name
nm

data BytecodeNameEnv = ByteCodeNameEnv { BytecodeNameEnv -> Word64
_bytecode_next_id :: !Word64
                                       , BytecodeNameEnv -> NameEnv Word64
_bytecode_name_subst :: NameEnv Word64
                                       }

addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
addBinNameWriter WriteBinHandle
bh' = do
  env_ref <- BytecodeNameEnv -> IO (IORef BytecodeNameEnv)
forall a. a -> IO (IORef a)
newIORef (Word64 -> NameEnv Word64 -> BytecodeNameEnv
ByteCodeNameEnv Word64
0 NameEnv Word64
forall a. NameEnv a
emptyNameEnv)
  evaluate
    $ flip addWriterToUserData bh'
    $ BinaryWriter
    $ \WriteBinHandle
bh (BinName Name
nm) ->
      if
        | Name -> Bool
isExternalName Name
nm -> do
            WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0
            WriteBinHandle -> Name -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Name
nm
        | Bool
otherwise -> do
            WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1
            key <- IORef BytecodeNameEnv -> Name -> IO Word64
getBinNameKey IORef BytecodeNameEnv
env_ref Name
nm
            -- Delimit the OccName from the deterministic counter to keep the
            -- encoding injective, avoiding collisions like "foo1" vs "foo#1".
            put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key))
  where
    -- Find a deterministic key for local names. This
    getBinNameKey :: IORef BytecodeNameEnv -> Name -> IO Word64
getBinNameKey IORef BytecodeNameEnv
ref Name
name = do
      IORef BytecodeNameEnv
-> (BytecodeNameEnv -> (BytecodeNameEnv, Word64)) -> IO Word64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef BytecodeNameEnv
ref (\b :: BytecodeNameEnv
b@(ByteCodeNameEnv Word64
next NameEnv Word64
subst) ->
        case NameEnv Word64 -> Name -> Maybe Word64
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Word64
subst Name
name of
          Just Word64
idx -> (BytecodeNameEnv
b, Word64
idx)
          Maybe Word64
Nothing  -> (Word64 -> NameEnv Word64 -> BytecodeNameEnv
ByteCodeNameEnv (Word64
next Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) (NameEnv Word64 -> Name -> Word64 -> NameEnv Word64
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv Word64
subst Name
name Word64
next), Word64
next))

addBinNameReader :: NameCache -> ReadBinHandle -> IO ReadBinHandle
addBinNameReader :: NameCache -> ReadBinHandle -> IO ReadBinHandle
addBinNameReader NameCache
nc ReadBinHandle
bh' = do
  env_ref <- OccEnv Name -> IO (IORef (OccEnv Name))
forall a. a -> IO (IORef a)
newIORef OccEnv Name
forall a. OccEnv a
emptyOccEnv
  pure $ flip addReaderToUserData bh' $ BinaryReader $ \ReadBinHandle
bh -> do
    t <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
    case t of
      Word8
0 -> do
        nm <- ReadBinHandle -> IO Name
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        pure $ BinName nm
      Word8
1 -> do
        occ <- FastString -> OccName
mkVarOccFS (FastString -> OccName) -> IO FastString -> IO OccName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO FastString
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
        -- We don't want to get a new unique from the NameCache each time we
        -- see a name.
        nm' <- unsafeInterleaveIO $ do
          u <- takeUniqFromNameCache nc
          evaluate $ mkInternalName u occ noSrcSpan
        fmap BinName $ atomicModifyIORef' env_ref $ \OccEnv Name
env ->
          case OccEnv Name -> OccName -> Maybe Name
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv Name
env OccName
occ of
            Just Name
nm -> (OccEnv Name
env, Name
nm)
            Maybe Name
_ -> Name
nm' Name -> (OccEnv Name, Name) -> (OccEnv Name, Name)
forall a b. a -> b -> b
`seq` (OccEnv Name -> OccName -> Name -> OccEnv Name
forall a. OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv OccEnv Name
env OccName
occ Name
nm', Name
nm')
      Word8
_ -> String -> IO BinName
forall a. HasCallStack => String -> a
panic String
"Binary BinName: invalid byte"

-- Note [Serializing Names in bytecode]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- The bytecode related types contain various Names which we need to
-- serialize. Unfortunately, we can't directly use the Binary instance
-- of Name: it is only meant to be used for serializing external Names
-- in BinIface logic, but bytecode does contain internal Names.
--
-- We also need to maintain the invariant that: any pair of internal
-- Names with equal/different uniques must also be deserialized to
-- have the same equality. Therefore when we write the names to the interface, we
-- use an incrementing counter to give each local name it's own unique number. A substitution
-- is maintained to give each occurence of the Name the same unique key. When the interface
-- is read, a reverse mapping is used from these unique keys to a Name.
--