{-# LANGUAGE MagicHash #-}
{-# 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.
{- | This module implements the serialization of bytecode objects to and from disk.
-}
module GHC.ByteCode.Serialize
  ( writeBinByteCode, readBinByteCode
  , ModuleByteCode(..)
  , BytecodeLibX(..)
  , BytecodeLib
  , OnDiskBytecodeLib
  , InterpreterLibrary(..)
  , InterpreterLibraryContents(..)
  , writeBytecodeLib
  , readBytecodeLib
  , mkModuleByteCode
  , fingerprintModuleByteCodeContents
  , decodeOnDiskModuleByteCode
  , decodeOnDiskBytecodeLib
  )
where

import GHC.Prelude

import GHC.ByteCode.Binary
import GHC.ByteCode.Recomp.Binary (computeFingerprint)
import GHC.ByteCode.Types
import GHC.Driver.DynFlags
import GHC.Driver.Env
import GHC.Iface.Binary
import GHC.Iface.Recomp.Binary (putNameLiterally)
import GHC.Linker.Types
import GHC.Settings.Constants (hiVersion)
import GHC.Unit.Types
import GHC.Utils.Binary
import GHC.Utils.Fingerprint (Fingerprint)
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Utils.TmpFs

import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Char (ord)
import Data.Traversable
import Data.Word
import System.Directory
import System.FilePath

{- 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]
See Note [Persistent bytecode file headers]

Note [Persistent bytecode file headers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Persistent bytecode files (`.gbc`) and bytecode libraries (`.bytecodelib`)
are version-specific binary formats. Without a small file-level header, stale
or corrupt files are only discovered once we start deserialising the payload,
which can lead to confusing failures.

To make these failures explicit, we write a file-kind-specific magic word and
the current `hiVersion` ahead of the binary payload. Readers validate this
header before setting up the normal `Name`/`FastString` deserialisation
machinery. This follows the same approach as normal interface files.
-}

writeBytecodeLib :: BytecodeLib -> FilePath -> IO ()
writeBytecodeLib :: BytecodeLib -> String -> IO ()
writeBytecodeLib BytecodeLib
lib String
path = do
  odbco <- BytecodeLib -> IO OnDiskBytecodeLib
encodeBytecodeLib BytecodeLib
lib
  createDirectoryIfMissing True (takeDirectory path)
  bh' <- openBinMem initBinMemSize
  bh <- addBinNameWriter bh'
  writePersistentBytecodeHeader BytecodeLibraryFile bh
  putWithUserData QuietBinIFace NormalCompression bh odbco
  writeBinMem bh path

readBytecodeLib :: HscEnv -> FilePath -> IO OnDiskBytecodeLib
readBytecodeLib :: HscEnv -> String -> IO OnDiskBytecodeLib
readBytecodeLib HscEnv
hsc_env String
path = do
  bh' <- String -> IO ReadBinHandle
readBinMem String
path
  readPersistentBytecodeHeader BytecodeLibraryFile path bh'
  bh <- addBinNameReader (hsc_NC hsc_env) bh'
  res <- getWithUserData (hsc_NC hsc_env) bh
  pure res

-- | 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 [String]
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,
    gbc_hash = odgbc_hash odbco
   }

decodeOnDiskBytecodeLib :: HscEnv -> OnDiskBytecodeLib -> IO BytecodeLib
decodeOnDiskBytecodeLib :: HscEnv -> OnDiskBytecodeLib -> IO BytecodeLib
decodeOnDiskBytecodeLib HscEnv
hsc_env OnDiskBytecodeLib
odbco = do
  foreign_contents <- (InterpreterLibraryContents -> IO InterpreterLibrary)
-> Maybe InterpreterLibraryContents
-> IO (Maybe InterpreterLibrary)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Logger
-> TmpFs
-> TempDir
-> InterpreterLibraryContents
-> IO InterpreterLibrary
writeInterpreterLibraryFile (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env) (DynFlags -> TempDir
tmpDir (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)))  (OnDiskBytecodeLib -> Maybe InterpreterLibraryContents
forall a. BytecodeLibX a -> a
bytecodeLibForeign OnDiskBytecodeLib
odbco)
  pure $ BytecodeLib {
    bytecodeLibUnitId = bytecodeLibUnitId odbco,
    bytecodeLibFiles = bytecodeLibFiles odbco,
    bytecodeLibForeign = foreign_contents
   }

encodeBytecodeLib :: BytecodeLib -> IO OnDiskBytecodeLib
encodeBytecodeLib :: BytecodeLib -> IO OnDiskBytecodeLib
encodeBytecodeLib (BytecodeLib {[CompiledByteCode]
Maybe InterpreterLibrary
UnitId
bytecodeLibForeign :: forall a. BytecodeLibX a -> a
bytecodeLibUnitId :: forall a. BytecodeLibX a -> UnitId
bytecodeLibFiles :: forall a. BytecodeLibX a -> [CompiledByteCode]
bytecodeLibUnitId :: UnitId
bytecodeLibFiles :: [CompiledByteCode]
bytecodeLibForeign :: Maybe InterpreterLibrary
..}) = do
  foreign_contents <- (InterpreterLibrary -> IO InterpreterLibraryContents)
-> Maybe InterpreterLibrary
-> IO (Maybe InterpreterLibraryContents)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse InterpreterLibrary -> IO InterpreterLibraryContents
readInterpreterLibraryFile Maybe InterpreterLibrary
bytecodeLibForeign
  pure $ BytecodeLib {
    bytecodeLibUnitId = bytecodeLibUnitId,
    bytecodeLibFiles = bytecodeLibFiles,
    bytecodeLibForeign = foreign_contents
   }

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

readObjectFiles :: [FilePath] -> IO [ByteString]
readObjectFiles :: [String] -> IO [ByteString]
readObjectFiles [String]
fs = (String -> IO ByteString) -> [String] -> 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 String -> IO ByteString
readObjectFile [String]
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 [String]
writeObjectFiles Logger
logger TmpFs
tmpfs TempDir
tmp_dir [ByteString]
files =
  [ByteString] -> (ByteString -> IO String) -> IO [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ByteString]
files ((ByteString -> IO String) -> IO [String])
-> (ByteString -> IO String) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \ByteString
file -> do
    f <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
TFL_GhcSession String
"o"
    BS.writeFile f file
    pure f

writeInterpreterLibraryFile :: Logger -> TmpFs -> TempDir -> InterpreterLibraryContents -> IO InterpreterLibrary
writeInterpreterLibraryFile :: Logger
-> TmpFs
-> TempDir
-> InterpreterLibraryContents
-> IO InterpreterLibrary
writeInterpreterLibraryFile Logger
logger TmpFs
tmpfs TempDir
tmp_dir (InterpreterLibrarySharedContents ByteString
contents) = do
  (soFile, libdir, libname)  <- Logger
-> TmpFs
-> TempDir
-> TempFileLifetime
-> String
-> IO (String, String, String)
newTempLibName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
TFL_GhcSession String
"so"
  BS.writeFile soFile contents
  pure (InterpreterSharedObject soFile libdir libname)
writeInterpreterLibraryFile Logger
logger TmpFs
tmpfs TempDir
tmp_dir (InterpreterLibraryStaticContents [ByteString]
contents) = do
  object_files <- Logger -> TmpFs -> TempDir -> [ByteString] -> IO [String]
writeObjectFiles Logger
logger TmpFs
tmpfs TempDir
tmp_dir [ByteString]
contents
  pure (InterpreterStaticObjects object_files)

readInterpreterLibraryFile :: InterpreterLibrary -> IO InterpreterLibraryContents
readInterpreterLibraryFile :: InterpreterLibrary -> IO InterpreterLibraryContents
readInterpreterLibraryFile (InterpreterSharedObject String
path String
_ String
_) = do
  contents <- String -> IO ByteString
BS.readFile String
path
  pure (InterpreterLibrarySharedContents contents)
readInterpreterLibraryFile (InterpreterStaticObjects [String]
paths) = do
  contents <- [String] -> IO [ByteString]
readObjectFiles [String]
paths
  pure (InterpreterLibraryStaticContents contents)

-- | Prepare an in-memory 'ModuleByteCode' for writing to disk.
encodeOnDiskModuleByteCode :: ModuleByteCode -> IO OnDiskModuleByteCode
encodeOnDiskModuleByteCode :: ModuleByteCode -> IO OnDiskModuleByteCode
encodeOnDiskModuleByteCode ModuleByteCode
bco = do
  foreign_contents <- [String] -> IO [ByteString]
readObjectFiles (ModuleByteCode -> [String]
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,
    odgbc_hash = gbc_hash bco
   }

-- | Read a 'ModuleByteCode' from a file.
readBinByteCode :: HscEnv -> FilePath -> IO ModuleByteCode
readBinByteCode :: HscEnv -> String -> IO ModuleByteCode
readBinByteCode HscEnv
hsc_env String
f = do
  odbco <- HscEnv -> String -> IO OnDiskModuleByteCode
readOnDiskModuleByteCode HscEnv
hsc_env String
f
  decodeOnDiskModuleByteCode hsc_env odbco

readOnDiskModuleByteCode :: HscEnv -> FilePath -> IO OnDiskModuleByteCode
readOnDiskModuleByteCode :: HscEnv -> String -> IO OnDiskModuleByteCode
readOnDiskModuleByteCode HscEnv
hsc_env String
f = do
  bh' <- String -> IO ReadBinHandle
readBinMem String
f
  readPersistentBytecodeHeader ModuleByteCodeFile f bh'
  bh <- addBinNameReader (hsc_NC hsc_env) bh'
  getWithUserData (hsc_NC hsc_env) bh

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

mkModuleByteCode :: Module -> CompiledByteCode -> [FilePath] -> IO ModuleByteCode
mkModuleByteCode :: Module -> CompiledByteCode -> [String] -> IO ModuleByteCode
mkModuleByteCode Module
modl CompiledByteCode
cbc [String]
foreign_files = do
  !bcos_hash <- Module -> CompiledByteCode -> [String] -> IO Fingerprint
fingerprintModuleByteCodeContents Module
modl CompiledByteCode
cbc [String]
foreign_files
  return $! ModuleByteCode modl cbc foreign_files bcos_hash

-- | Generate a 'Fingerprint' for the 'ModuleByteCode' contents.
--
-- Note, this will serialise the contents of the 'ModuleByteCode' separately
-- to 'writeBytecodeLib'.
-- This means, if the 'ModuleByteCode' is written to disk, it will be
-- serialised twice.
fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [FilePath] -> IO Fingerprint
fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [String] -> IO Fingerprint
fingerprintModuleByteCodeContents Module
modl CompiledByteCode
cbc [String]
foreign_files = do
  foreign_contents <- [String] -> IO [ByteString]
readObjectFiles [String]
foreign_files
  pure $ computeFingerprint putNameLiterally (modl, cbc, foreign_contents)

-- ----------------------------------------------------------------------------
-- ByteCode module and library magic header.
-- ----------------------------------------------------------------------------

data PersistentBytecodeFile
  = ModuleByteCodeFile
  | BytecodeLibraryFile

-- See Note [Persistent bytecode file headers]
writePersistentBytecodeHeader :: PersistentBytecodeFile -> WriteBinHandle -> IO ()
writePersistentBytecodeHeader :: PersistentBytecodeFile -> WriteBinHandle -> IO ()
writePersistentBytecodeHeader PersistentBytecodeFile
file_kind WriteBinHandle
bh = do
  WriteBinHandle -> FixedLengthEncoding Word32 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (PersistentBytecodeFile -> FixedLengthEncoding Word32
persistentBytecodeMagic PersistentBytecodeFile
file_kind)
  WriteBinHandle -> String -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Integer -> String
forall a. Show a => a -> String
show Integer
hiVersion)

readPersistentBytecodeHeader :: PersistentBytecodeFile -> FilePath -> ReadBinHandle -> IO ()
readPersistentBytecodeHeader :: PersistentBytecodeFile -> String -> ReadBinHandle -> IO ()
readPersistentBytecodeHeader PersistentBytecodeFile
file_kind String
path ReadBinHandle
bh = do
  let mismatch :: String -> String -> String -> IO ()
mismatch String
what String
expected String
actual =
        GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> GhcException
String -> GhcException
ProgramError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$
          PersistentBytecodeFile -> String
persistentBytecodeFileDescription PersistentBytecodeFile
file_kind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" header mismatch in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
actual String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

  magic <- ReadBinHandle -> IO (FixedLengthEncoding Word32)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
  let expected_magic = PersistentBytecodeFile -> FixedLengthEncoding Word32
persistentBytecodeMagic PersistentBytecodeFile
file_kind
  if unFixedLength magic == unFixedLength expected_magic
    then pure ()
    else mismatch "magic" (show $ unFixedLength expected_magic) (show $ unFixedLength magic)

  version <- get bh
  let expected_version = Integer -> String
forall a. Show a => a -> String
show Integer
hiVersion
  if version == expected_version
    then pure ()
    else mismatch "version" expected_version version

persistentBytecodeFileDescription :: PersistentBytecodeFile -> String
persistentBytecodeFileDescription :: PersistentBytecodeFile -> String
persistentBytecodeFileDescription PersistentBytecodeFile
ModuleByteCodeFile = String
"bytecode file"
persistentBytecodeFileDescription PersistentBytecodeFile
BytecodeLibraryFile = String
"bytecode library"

persistentBytecodeMagic :: PersistentBytecodeFile -> FixedLengthEncoding Word32
persistentBytecodeMagic :: PersistentBytecodeFile -> FixedLengthEncoding Word32
persistentBytecodeMagic PersistentBytecodeFile
file_kind =
  case PersistentBytecodeFile
file_kind of
    PersistentBytecodeFile
ModuleByteCodeFile -> String -> FixedLengthEncoding Word32
asciiWord32 String
"gbc0"
    PersistentBytecodeFile
BytecodeLibraryFile -> String -> FixedLengthEncoding Word32
asciiWord32 String
"bcl0"

-- | Encode a 4-letter word into a single Word32.
asciiWord32 :: String -> FixedLengthEncoding Word32
asciiWord32 :: String -> FixedLengthEncoding Word32
asciiWord32 [Char
a, Char
b, Char
c, Char
d] =
  Word32 -> FixedLengthEncoding Word32
Word32 -> FixedLengthEncoding Word32
forall a. a -> FixedLengthEncoding a
FixedLengthEncoding (Word32 -> FixedLengthEncoding Word32)
-> Word32 -> FixedLengthEncoding Word32
forall a b. (a -> b) -> a -> b
$
    (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
a) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24) 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
b) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) 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
8)  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
d)
asciiWord32 String
_ = String -> FixedLengthEncoding Word32
forall a. HasCallStack => String -> a
error String
"asciiWord32: expected exactly four ASCII characters"

-- ----------------------------------------------------------------------------
-- Constants and utils
-- ----------------------------------------------------------------------------

-- | Initial ram buffer to allocate for writing .gbc and .bytecodelib files.
initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 -- 1 MB