{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
-- Orphans are here since the Binary instances use an ad-hoc means of serialising
-- names which we don't want to pollute the rest of the codebase with.
{-# OPTIONS_GHC -Wno-orphans #-}
{- | This module implements the serialization of bytecode objects to and from disk.
-}
module GHC.ByteCode.Serialize
  ( writeBinByteCode, readBinByteCode, ModuleByteCode(..)
  )
where

import Control.Monad
import Data.Binary qualified as Binary
import Data.Foldable
import Data.IORef
import Data.Proxy
import Data.Word
import GHC.ByteCode.Types
import GHC.Data.FastString
import GHC.Driver.Env
import GHC.Iface.Binary
import GHC.Prelude
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Types.SrcLoc
import GHC.Utils.Binary
import GHC.Utils.Exception
import GHC.Utils.Panic
import GHC.Utils.TmpFs
import System.FilePath
import GHC.Unit.Types
import GHC.Driver.DynFlags
import System.Directory
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Traversable
import GHC.Utils.Logger
import GHC.Linker.Types
import System.IO.Unsafe (unsafeInterleaveIO)

{- Note [Overview of persistent bytecode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

By default, when using the interpreter, a Haskell module is first compiled to
bytecode (which lives in memory) and then executed by the RTS interpreter.
However, when dealing with many modules compiling to bytecode from scratch every
time is expensive. This is especially relevant for interpreter-heavy workflows
on large projects where changes are incremental or non-existent (e.g. running
the project in the debugger).

In light of this, GHC can produce `.gbc` files, which contain a
serialized representation of the bytecode for a Haskell module. These
files are written by enabling the flag `-fwrite-byte-code` when using the
interpreter.

The driver will always look for both the interface and the `.gbc` file and load
those to avoid unnecessary recompilation. This can save a lot of time if you
have many modules. Even compared to `-fwrite-if-simplified-core`.

.gbc files are standalone, in the sense that they can be loaded into the interpreter
without having the interface file or source files available. In the future you could
create a "bytecode executable", which just contained bytecode objects, a simple wrapper
and the runtime, which would load the bytecode objects and execute main.

.gbc files also contain the contents of object files which arise from foreign files
and other stubs (such as info table map, foreign files added by TH, CApiFFI
etc). In the normal compilation pipeline, these are merged into the final object
by object merging to produce a single .o file. Bytecode objects are not "normal
objects", so they are stored alongside the 'CompiledByteCode' and written to
temporary files when needed.

The ticket where bytecode objects were dicussed is #26298

See Note [-fwrite-byte-code is not the default]
See Note [Recompilation avoidance with bytecode objects]

-}

-- | 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 -> CompiledByteCode
odgbc_compiled_byte_code :: CompiledByteCode
                                                 , OnDiskModuleByteCode -> [ByteString]
odgbc_foreign :: [ByteString]  -- ^ Contents of object files
                                                 }


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

  put_ :: WriteBinHandle -> OnDiskModuleByteCode -> IO ()
put_ WriteBinHandle
bh OnDiskModuleByteCode {[ByteString]
Module
CompiledByteCode
odgbc_module :: OnDiskModuleByteCode -> Module
odgbc_compiled_byte_code :: OnDiskModuleByteCode -> CompiledByteCode
odgbc_foreign :: OnDiskModuleByteCode -> [ByteString]
odgbc_module :: Module
odgbc_compiled_byte_code :: CompiledByteCode
odgbc_foreign :: [ByteString]
..} = do
    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 ()
put_ WriteBinHandle
bh CompiledByteCode
odgbc_compiled_byte_code
    WriteBinHandle -> [ByteString] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [ByteString]
odgbc_foreign

-- | Convert an 'OnDiskModuleByteCode' to an 'ModuleByteCode'.
-- 'OnDiskModuleByteCode' is the representation which we read from a file,
-- the 'ModuleByteCode' is the representation which is manipulated by program logic.
--
-- This notably writes the object files to temporary files.
-- They are written to temporary files so that the normal object file loading
-- code paths (which expect object files to exist as on-disk files) can be used
-- in the loader.
decodeOnDiskModuleByteCode :: HscEnv -> OnDiskModuleByteCode -> IO ModuleByteCode
decodeOnDiskModuleByteCode :: HscEnv -> OnDiskModuleByteCode -> IO ModuleByteCode
decodeOnDiskModuleByteCode HscEnv
hsc_env OnDiskModuleByteCode
odbco = do
  foreign_files <- Logger -> TmpFs -> TempDir -> [ByteString] -> IO [FilePath]
writeObjectFiles (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env) (DynFlags -> TempDir
tmpDir (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) (OnDiskModuleByteCode -> [ByteString]
odgbc_foreign OnDiskModuleByteCode
odbco)
  pure $ ModuleByteCode {
    gbc_module = odgbc_module odbco,
    gbc_compiled_byte_code = odgbc_compiled_byte_code odbco,
    gbc_foreign_files = foreign_files
   }

readObjectFile :: FilePath -> IO ByteString
readObjectFile :: FilePath -> IO ByteString
readObjectFile FilePath
f = FilePath -> IO ByteString
BS.readFile FilePath
f

readObjectFiles :: [FilePath] -> IO [ByteString]
readObjectFiles :: [FilePath] -> IO [ByteString]
readObjectFiles [FilePath]
fs = (FilePath -> IO ByteString) -> [FilePath] -> IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> IO ByteString
readObjectFile [FilePath]
fs

-- | Write a list of bytestrings, representing object files, to a temporary files.
writeObjectFiles ::  Logger -> TmpFs -> TempDir -> [ByteString] -> IO [FilePath]
writeObjectFiles :: Logger -> TmpFs -> TempDir -> [ByteString] -> IO [FilePath]
writeObjectFiles Logger
logger TmpFs
tmpfs TempDir
tmp_dir [ByteString]
files =
  [ByteString] -> (ByteString -> IO FilePath) -> IO [FilePath]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ByteString]
files ((ByteString -> IO FilePath) -> IO [FilePath])
-> (ByteString -> IO FilePath) -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ \ByteString
file -> do
    f <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> FilePath -> IO FilePath
newTempName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
TFL_GhcSession FilePath
"o"
    BS.writeFile f file
    pure f

-- | Prepare an in-memory 'ModuleByteCode' for writing to disk.
encodeOnDiskModuleByteCode :: ModuleByteCode -> IO OnDiskModuleByteCode
encodeOnDiskModuleByteCode :: ModuleByteCode -> IO OnDiskModuleByteCode
encodeOnDiskModuleByteCode ModuleByteCode
bco = do
  foreign_contents <- [FilePath] -> IO [ByteString]
readObjectFiles (ModuleByteCode -> [FilePath]
gbc_foreign_files ModuleByteCode
bco)
  pure $ OnDiskModuleByteCode {
    odgbc_module = gbc_module bco,
    odgbc_compiled_byte_code = gbc_compiled_byte_code bco,
    odgbc_foreign = foreign_contents
   }

-- | Read a 'ModuleByteCode' from a file.
readBinByteCode :: HscEnv -> FilePath -> IO ModuleByteCode
readBinByteCode :: HscEnv -> FilePath -> IO ModuleByteCode
readBinByteCode HscEnv
hsc_env FilePath
f = do
  bh' <- FilePath -> IO ReadBinHandle
readBinMem FilePath
f
  bh <- addBinNameReader hsc_env bh'
  odbco <- getWithUserData (hsc_NC hsc_env) bh
  decodeOnDiskModuleByteCode hsc_env odbco

-- | Write a 'ModuleByteCode' to a file.
writeBinByteCode :: FilePath -> ModuleByteCode -> IO ()
writeBinByteCode :: FilePath -> ModuleByteCode -> IO ()
writeBinByteCode FilePath
f ModuleByteCode
cbc = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
f)
  bh' <- Int -> IO WriteBinHandle
openBinMem (Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024)
  bh <- addBinNameWriter bh'
  odbco <- encodeOnDiskModuleByteCode cbc
  putWithUserData QuietBinIFace NormalCompression bh odbco
  writeBinMem bh f

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 =
    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
<*> (ByteString -> BCOByteArray Word16
forall a. Binary a => ByteString -> a
Binary.decode (ByteString -> BCOByteArray Word16)
-> IO ByteString -> IO (BCOByteArray Word16)
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)
      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
<*> (ByteString -> BCOByteArray Word
forall a. Binary a => ByteString -> a
Binary.decode (ByteString -> BCOByteArray Word)
-> IO ByteString -> IO (BCOByteArray Word)
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)
      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

  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 -> Name -> IO ()
putViaBinName WriteBinHandle
bh Name
unlinkedBCOName
    WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Int
unlinkedBCOArity
    WriteBinHandle -> ByteString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ BCOByteArray Word16 -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode BCOByteArray Word16
unlinkedBCOInstrs
    WriteBinHandle -> ByteString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ BCOByteArray Word -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode 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

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
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
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
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
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
_ -> FilePath -> IO BCOPtr
forall a. HasCallStack => FilePath -> a
panic FilePath
"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
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
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
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
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
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
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
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
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
_ -> FilePath -> IO BCONPtr
forall a. HasCallStack => FilePath -> a
panic FilePath
"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

addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
addBinNameWriter WriteBinHandle
bh' =
  WriteBinHandle -> IO WriteBinHandle
forall a. a -> IO a
evaluate
    (WriteBinHandle -> IO WriteBinHandle)
-> WriteBinHandle -> IO WriteBinHandle
forall a b. (a -> b) -> a -> b
$ (BinaryWriter BinName -> WriteBinHandle -> WriteBinHandle)
-> WriteBinHandle -> BinaryWriter BinName -> WriteBinHandle
forall a b c. (a -> b -> c) -> b -> a -> c
flip BinaryWriter BinName -> WriteBinHandle -> WriteBinHandle
forall a.
Typeable a =>
BinaryWriter a -> WriteBinHandle -> WriteBinHandle
addWriterToUserData WriteBinHandle
bh'
    (BinaryWriter BinName -> WriteBinHandle)
-> BinaryWriter BinName -> WriteBinHandle
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> BinName -> IO ()) -> BinaryWriter BinName
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
BinaryWriter
    ((WriteBinHandle -> BinName -> IO ()) -> BinaryWriter BinName)
-> (WriteBinHandle -> BinName -> IO ()) -> BinaryWriter BinName
forall a b. (a -> b) -> a -> b
$ \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
            WriteBinHandle -> FastString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh
              (FastString -> IO ()) -> FastString -> IO ()
forall a b. (a -> b) -> a -> b
$ OccName -> FastString
occNameFS (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
nm)
              FastString -> FastString -> FastString
`appendFS` FilePath -> FastString
mkFastString
                (Unique -> FilePath
forall a. Show a => a -> FilePath
show (Unique -> FilePath) -> Unique -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> Unique
nameUnique Name
nm)

addBinNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
addBinNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
addBinNameReader HscEnv {[Target]
Maybe Interp
Logger
TmpFs
DynFlags
KnotVars (IORef TypeEnv)
LlvmConfigCache
NameCache
UnitEnv
FinderCache
Hooks
Plugins
InteractiveContext
hsc_logger :: HscEnv -> Logger
hsc_tmpfs :: HscEnv -> TmpFs
hsc_dflags :: HscEnv -> DynFlags
hsc_NC :: HscEnv -> NameCache
hsc_dflags :: DynFlags
hsc_targets :: [Target]
hsc_IC :: InteractiveContext
hsc_NC :: NameCache
hsc_FC :: FinderCache
hsc_type_env_vars :: KnotVars (IORef TypeEnv)
hsc_interp :: Maybe Interp
hsc_plugins :: Plugins
hsc_unit_env :: UnitEnv
hsc_logger :: Logger
hsc_hooks :: Hooks
hsc_tmpfs :: TmpFs
hsc_llvm_config :: LlvmConfigCache
hsc_llvm_config :: HscEnv -> LlvmConfigCache
hsc_hooks :: HscEnv -> Hooks
hsc_unit_env :: HscEnv -> UnitEnv
hsc_plugins :: HscEnv -> Plugins
hsc_interp :: HscEnv -> Maybe Interp
hsc_type_env_vars :: HscEnv -> KnotVars (IORef TypeEnv)
hsc_FC :: HscEnv -> FinderCache
hsc_IC :: HscEnv -> InteractiveContext
hsc_targets :: HscEnv -> [Target]
..} 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 hsc_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
_ -> FilePath -> IO BinName
forall a. HasCallStack => FilePath -> a
panic FilePath
"Binary BinName: invalid byte"

-- Note [Serializing Names in bytecode]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- NOTE: This approach means that bytecode objects are not deterministic.
-- We need to revisit this in order to make the output deterministic.
--
-- 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. So normally uniques aren't supposed to be
-- serialized, but for this invariant to work, we do append uniques to
-- OccNames of internal Names, so that they can be uniquely identified
-- by OccName alone. When deserializing, we check a global cached
-- mapping from OccName to Unique, and create the real Name with the
-- right Unique if it's already deserialized at least once.