{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE DuplicateRecordFields #-}

module GHC.Unit.Module.WholeCoreBindings where

import GHC.Cmm.CLabel
import GHC.Driver.DynFlags (DynFlags (targetPlatform), initSDocContext)
import GHC.ForeignSrcLang (ForeignSrcLang (..))
import GHC.Iface.Syntax
import GHC.Prelude
import GHC.Types.ForeignStubs
import GHC.Unit.Module.Location
import GHC.Unit.Types (Module)
import GHC.Utils.Binary
import GHC.Utils.Error (debugTraceMsg)
import GHC.Utils.Logger (Logger)
import GHC.Utils.Outputable
import GHC.Utils.Panic (panic, pprPanic)
import GHC.Utils.TmpFs

import Control.DeepSeq (NFData (..))
import Data.Traversable (for)
import Data.Word (Word8)
import Data.Maybe (fromMaybe)
import System.FilePath (takeExtension)

{-
Note [Interface Files with Core Definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

A interface file can optionally contain the definitions of all core bindings, this
is enabled by the flag `-fwrite-if-simplified-core`.
This provides everything needed in addition to the normal ModIface and ModDetails
to restart compilation after typechecking to generate bytecode. The `wcb_bindings` field
is stored in the normal interface file and the other fields populated whilst loading
the interface file.

The lifecycle of a WholeCoreBindings typically proceeds as follows:

1. The ModIface which contains mi_extra_decls is loaded from disk. A linkable is
   created (which is headed by the `CoreBindings` constructor). This is an unhydrated set of bindings which
   is currently unsuitable for linking, but at the point it is loaded, the ModIface
   hasn't been hydrated yet (See Note [Hydrating Modules]) either so the CoreBindings constructor allows the delaying of converting
   the WholeCoreBindings into a proper Linkable (if we ever do that). The CoreBindings constructor also
   allows us to convert the WholeCoreBindings into multiple different linkables if we so desired.

2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCOs linkable. This step combines together
   all the necessary information from a ModIface, ModDetails and WholeCoreBindings in order to
   create the linkable. The linkable created is a "LazyBCOs" linkable, which
   was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazily.
   Using the `BCOs` constructor directly here leads to the bytecode being forced
   too eagerly.

3. Then when bytecode is needed, the LazyBCOs value is inspected and unpacked and
   the linkable is used as before.

The flag `-fwrite-if-simplified-core` determines whether the extra information is written
to an interface file. The program which is written is the core bindings of the module
after whatever simplification the user requested has been performed. So the simplified core bindings
of the interface file agree with the optimisation level as reported by the interface
file.

The lifecycle differs beyond laziness depending on the provenance of a module.
In all cases, the main consumer for interface bytecode is 'get_link_deps', which
traverses a splice's or GHCi expression's dependencies and collects the needed
build artifacts, which can be objects or bytecode, depending on the build
settings.

1. In make mode, all eligible modules are part of the dependency graph.
   Their interfaces are loaded unconditionally and in dependency order by the
   compilation manager, and each module's bytecode is prepared before its
   dependents are compiled, in one of two ways:

   - If the interface file for a module is missing or out of sync with its
     source, it is recompiled and bytecode is generated directly and
     immediately, not involving 'WholeCoreBindings' (in 'runHscBackendPhase').

   - If the interface file is up to date, no compilation is performed, and a
     lazy thunk generating bytecode from interface Core bindings is created in
     'compileOne'', which will only be compiled if a downstream module contains
     a splice that depends on it, as described above.

   In both cases, the bytecode 'Linkable' is stored in a 'HomeModLinkable' in
   the Home Unit Graph, lazy or not.

2. In oneshot mode, which compiles individual modules without a shared home unit
   graph, a previously compiled module is not reprocessed as described for make
   mode above.
   When 'get_link_deps' encounters a dependency on a local module, it requests
   its bytecode from the External Package State, who loads the interface
   on-demand.

   Since the EPS stores interfaces for all package dependencies in addition to
   local modules in oneshot mode, it has a substantial memory footprint.
   We try to curtail that by extracting important data into specialized fields
   in the EPS, and retaining only a few fields of 'ModIface' by overwriting the
   others with bottom values.

   In order to avoid keeping around all of the interface's components needed for
   compiling bytecode, we instead store an IO action in 'eps_iface_bytecode'.
   When 'get_link_deps' evaluates this action, the result is not retained in the
   EPS, but stored in 'LoaderState', where it may eventually get evicted to free
   up the memory.
   This IO action retains the dehydrated Core bindings from the interface in its
   closure.
   Like the bytecode 'Linkable' stored in 'LoaderState', this is preferable to
   storing the intermediate representation as rehydrated Core bindings, since
   the latter have a significantly greater memory footprint.

Note [Size of Interface Files with Core Definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

How much overhead does `-fwrite-if-simplified-core` add to a typical interface file?
As an experiment I compiled the `Cabal` library and `ghc` library (Aug 22) with

| Project | .hi  | .hi (fat) | .o   |
| --------| ---- | --------- | --   |
| ghc     | 32M  | 68M       | 127M |
| Cabal   | 3.2M | 9.8M      | 14M  |

So the interface files gained in size but the end result was still smaller than
the object files.

-}

data WholeCoreBindings = WholeCoreBindings
            { WholeCoreBindings -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -- ^ serialised tidied core bindings.
            , WholeCoreBindings -> Module
wcb_module   :: Module  -- ^ The module which the bindings are for
            , WholeCoreBindings -> ModLocation
wcb_mod_location :: ModLocation -- ^ The location where the sources reside.
              -- | Stubs for foreign declarations and files added via
              -- 'GHC.Internal.TH.Syntax.addForeignFilePath'.
            , WholeCoreBindings -> IfaceForeign
wcb_foreign :: IfaceForeign
            }

{-
Note [Foreign stubs and TH bytecode linking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Foreign declarations may introduce additional build products called "stubs" that
contain wrappers for the exposed functions.
For example, consider a foreign import of a C function named @main_loop@ from
the file @bindings.h@ in the module @CLibrary@:

@
foreign import capi "bindings.h main_loop" mainLoop :: IO Int
@

GHC will generate a snippet of C code containing a wrapper:

@
#include "bindings.h"
HsInt ghczuwrapperZC0ZCmainZCCLibraryZCmainzuloop(void) {return main_loop();}
@

Wrappers like these are generated as 'ForeignStubs' by the desugarer in
'dsForeign' and stored in the various @*Guts@ types; until they are compiled to
temporary object files in 'runHscBackendPhase' during code generation and
ultimately merged into the final object file for the module, @CLibrary.o@.

This creates some problems with @-fprefer-byte-code@, which allows splices to
execute bytecode instead of native code for dependencies that provide it.
Usually, when some TH code depends on @CLibrary@, the linker would look for
@CLibrary.o@ and load that before executing the splice, but with this flag, it
will first attempt to load bytecode from @CLibrary.hi@ and compile it in-memory.

Problem 1:

Code for splices is loaded from interfaces in the shape of Core bindings
(see 'WholeCoreBindings'), rather than from object files.
Those Core bindings are intermediate build products that do not contain the
module's stubs, since those are separated from the Haskell code before Core is
generated and only compiled and linked into the final object when native code is
generated.

Therefore, stubs have to be stored separately in interface files.
Unfortunately, the type 'ForeignStubs' contains 'CLabel', which is a huge type
with several 'Unique's used mainly by C--.
Luckily, the only constructor used for foreign stubs is 'ModuleLabel', which
contains the name of a foreign declaration's initializer, if it has one.
So we convert a 'CLabel' to 'CStubLabel' in 'encodeIfaceForeign' and store only
the simplified data.

Problem 2:

Given module B, which contains a splice that executes code from module A, both
in the home package, consider these different circumstances:

1. In make mode, both modules are recompiled
2. In make mode, only B is recompiled
3. In oneshot mode, B is compiled

In case 1, 'runHscBackendPhase' directly generates bytecode from the 'CgGuts'
that the main pipeline produced and stores it in the 'HomeModLinkable' that is
one of its build products.
The stubs are merged into a single object and added to the 'HomeModLinkable' in
'hscGenBackendPipeline'.

In case 2, 'hscRecompStatus' short-circuits the pipeline while checking A, since
the module is up to date.
Nevertheless, it calls 'checkByteCode', which extracts Core bindings from A's
interface and adds them to the 'HomeModLinkable'.
No stubs are generated in this case, since the desugarer wasn't run!

In both of these cases, 'compileOne'' proceeds to call 'initWholeCoreBindings',
applied to the 'HomeModLinkable', to compile Core bindings (lazily) to bytecode,
which is then written back to the 'HomeModLinkable'.
If the 'HomeModLinkable' already contains bytecode (case 1), this is a no-op.
Otherwise, the stub objects from the interface are compiled to objects in
'generateByteCode' and added to the 'HomeModLinkable' as well.

Case 3 is not implemented yet (!13042).

Problem 3:

In all three cases, the final step before splice execution is linking.

The function 'getLinkDeps' is responsible for assembling all of a splice's
dependencies, looking up imported modules in the HPT and EPS, collecting all
'HomeModLinkable's and object files that it can find.

However, since splices are executed in the interpreter, the 'Way' of the current
build may differ from the interpreter's.
For example, the current GHC invocation might be building a static binary, but
the internal interpreter requires dynamic linking; or profiling might be
enabled.
To adapt to the interpreter's 'Way', 'getLinkDeps' substitutes all object files'
extensions with that corresponding to that 'Way' – e.g. changing @.o@ to
@.dyn_o@, which requires dependencies to be built with @-dynamic[-too]@, which
in turn is enforced after downsweep in 'GHC.Driver.Make.enableCodeGenWhen'.

This doesn't work for stub objects, though – they are compiled to temporary
files with mismatching names, so simply switching out the suffix would refer to
a nonexisting file.
Even if that wasn't an issue, they are compiled for the session's 'Way', not its
associated module's, so the dynamic variant wouldn't be available when building
only static outputs.

To mitigate this, we instead build foreign objects specially for the
interpreter, updating the build flags in 'compile_for_interpreter' to use the
interpreter's way.

Problem 4:

Foreign code may have dependencies on Haskell code.

Both foreign exports and @StaticPointers@ produce stubs that contain @extern@
declarations of values referring to STG closures.
When those stub objects are loaded, the undefined symbols need to be provided to
the linker.

I have no insight into how this works, and whether we could provide the memory
address of a BCO as a ccall symbol while linking, so it's unclear at the moment
what to do about this.

In addition to that, those objects would also have to be loaded _after_
bytecode, and therefore 'DotO' would have to be marked additionally to separate
them from those that are loaded before.
If mutual dependencies between BCOs and foreign code are possible, this will be
much more diffcult though.

Problem 5:

TH allows splices to add arbitrary files as additional linker inputs.

Using the method `qAddForeignFilePath`, a foreign source file or a precompiled
object file can be added to the current modules dependencies.
These files will be processed by the pipeline and linked into the final object.

Since the files may be temporarily created from a string, we have to read their
contents in 'encodeIfaceForeign' and store them in the interface as well, and
write them to temporary files when loading bytecode in 'decodeIfaceForeign'.
-}

-- | Wrapper for avoiding a dependency on 'Binary' and 'NFData' in 'CLabel'.
newtype IfaceCLabel = IfaceCLabel CStubLabel

instance Binary IfaceCLabel where
  get :: ReadBinHandle -> IO IfaceCLabel
get ReadBinHandle
bh = do
    csl_is_initializer <- ReadBinHandle -> IO Bool
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
    csl_module <- get bh
    csl_name <- get bh
    pure (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name})

  put_ :: WriteBinHandle -> IfaceCLabel -> IO ()
put_ WriteBinHandle
bh (IfaceCLabel CStubLabel {Bool
csl_is_initializer :: CStubLabel -> Bool
csl_is_initializer :: Bool
csl_is_initializer, Module
csl_module :: CStubLabel -> Module
csl_module :: Module
csl_module, FastString
csl_name :: CStubLabel -> FastString
csl_name :: FastString
csl_name}) = do
    WriteBinHandle -> Bool -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Bool
csl_is_initializer
    WriteBinHandle -> Module -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Module
csl_module
    WriteBinHandle -> FastString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FastString
csl_name

instance NFData IfaceCLabel where
  rnf :: IfaceCLabel -> ()
rnf (IfaceCLabel CStubLabel {Bool
csl_is_initializer :: CStubLabel -> Bool
csl_is_initializer :: Bool
csl_is_initializer, Module
csl_module :: CStubLabel -> Module
csl_module :: Module
csl_module, FastString
csl_name :: CStubLabel -> FastString
csl_name :: FastString
csl_name}) =
    Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
csl_is_initializer () -> () -> ()
forall a b. a -> b -> b
`seq` Module -> ()
forall a. NFData a => a -> ()
rnf Module
csl_module () -> () -> ()
forall a b. a -> b -> b
`seq` FastString -> ()
forall a. NFData a => a -> ()
rnf FastString
csl_name

instance Outputable IfaceCLabel where
  ppr :: IfaceCLabel -> SDoc
ppr (IfaceCLabel CStubLabel
l) = CStubLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CStubLabel
l

-- | Simplified encoding of 'GHC.Types.ForeignStubs.ForeignStubs' for interface
-- serialization.
--
-- See Note [Foreign stubs and TH bytecode linking]
data IfaceCStubs =
  IfaceCStubs {
    IfaceCStubs -> String
header :: String,
    IfaceCStubs -> String
source :: String,
    IfaceCStubs -> [IfaceCLabel]
initializers :: [IfaceCLabel],
    IfaceCStubs -> [IfaceCLabel]
finalizers :: [IfaceCLabel]
  }

instance Outputable IfaceCStubs where
  ppr :: IfaceCStubs -> SDoc
ppr IfaceCStubs {String
header :: IfaceCStubs -> String
header :: String
header, String
source :: IfaceCStubs -> String
source :: String
source, [IfaceCLabel]
initializers :: IfaceCStubs -> [IfaceCLabel]
initializers :: [IfaceCLabel]
initializers, [IfaceCLabel]
finalizers :: IfaceCStubs -> [IfaceCLabel]
finalizers :: [IfaceCLabel]
finalizers} =
    [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"header:") Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> [String] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
lines String
header)),
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"source:") Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> [String] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
lines String
source)),
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"initializers:") Int
2 ([IfaceCLabel] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfaceCLabel]
initializers),
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"finalizers:") Int
2 ([IfaceCLabel] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [IfaceCLabel]
finalizers)
    ]

-- | 'Binary' 'put_' for 'ForeignSrcLang'.
binary_put_ForeignSrcLang :: WriteBinHandle -> ForeignSrcLang -> IO ()
binary_put_ForeignSrcLang :: WriteBinHandle -> ForeignSrcLang -> IO ()
binary_put_ForeignSrcLang WriteBinHandle
bh ForeignSrcLang
lang =
  forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ @Word8 WriteBinHandle
bh (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ case ForeignSrcLang
lang of
    ForeignSrcLang
LangC -> Word8
0
    ForeignSrcLang
LangCxx -> Word8
1
    ForeignSrcLang
LangObjc -> Word8
2
    ForeignSrcLang
LangObjcxx -> Word8
3
    ForeignSrcLang
LangAsm -> Word8
4
    ForeignSrcLang
LangJs -> Word8
5
    ForeignSrcLang
RawObject -> Word8
6

-- | 'Binary' 'get' for 'ForeignSrcLang'.
binary_get_ForeignSrcLang :: ReadBinHandle -> IO ForeignSrcLang
binary_get_ForeignSrcLang :: ReadBinHandle -> IO ForeignSrcLang
binary_get_ForeignSrcLang ReadBinHandle
bh = do
  b <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
  pure $ case b of
    Word8
0 -> ForeignSrcLang
LangC
    Word8
1 -> ForeignSrcLang
LangCxx
    Word8
2 -> ForeignSrcLang
LangObjc
    Word8
3 -> ForeignSrcLang
LangObjcxx
    Word8
4 -> ForeignSrcLang
LangAsm
    Word8
5 -> ForeignSrcLang
LangJs
    Word8
6 -> ForeignSrcLang
RawObject
    Word8
_ -> String -> ForeignSrcLang
forall a. HasCallStack => String -> a
panic String
"invalid Binary value for ForeignSrcLang"

instance Binary IfaceCStubs where
  get :: ReadBinHandle -> IO IfaceCStubs
get ReadBinHandle
bh = do
    header <- ReadBinHandle -> IO String
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
    source <- get bh
    initializers <- get bh
    finalizers <- get bh
    pure IfaceCStubs {..}

  put_ :: WriteBinHandle -> IfaceCStubs -> IO ()
put_ WriteBinHandle
bh IfaceCStubs {String
[IfaceCLabel]
header :: IfaceCStubs -> String
source :: IfaceCStubs -> String
initializers :: IfaceCStubs -> [IfaceCLabel]
finalizers :: IfaceCStubs -> [IfaceCLabel]
header :: String
source :: String
initializers :: [IfaceCLabel]
finalizers :: [IfaceCLabel]
..} = do
    WriteBinHandle -> String -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh String
header
    WriteBinHandle -> String -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh String
source
    WriteBinHandle -> [IfaceCLabel] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [IfaceCLabel]
initializers
    WriteBinHandle -> [IfaceCLabel] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [IfaceCLabel]
finalizers

instance NFData IfaceCStubs where
  rnf :: IfaceCStubs -> ()
rnf IfaceCStubs {String
[IfaceCLabel]
header :: IfaceCStubs -> String
source :: IfaceCStubs -> String
initializers :: IfaceCStubs -> [IfaceCLabel]
finalizers :: IfaceCStubs -> [IfaceCLabel]
header :: String
source :: String
initializers :: [IfaceCLabel]
finalizers :: [IfaceCLabel]
..} =
    String -> ()
forall a. NFData a => a -> ()
rnf String
header
    () -> () -> ()
forall a b. a -> b -> b
`seq`
    String -> ()
forall a. NFData a => a -> ()
rnf String
source
    () -> () -> ()
forall a b. a -> b -> b
`seq`
    [IfaceCLabel] -> ()
forall a. NFData a => a -> ()
rnf [IfaceCLabel]
initializers
    () -> () -> ()
forall a b. a -> b -> b
`seq`
    [IfaceCLabel] -> ()
forall a. NFData a => a -> ()
rnf [IfaceCLabel]
finalizers

-- | A source file added from Template Haskell using 'qAddForeignFilePath', for
-- storage in interfaces.
--
-- See Note [Foreign stubs and TH bytecode linking]
data IfaceForeignFile =
  IfaceForeignFile {
    -- | The language is specified by the user.
    IfaceForeignFile -> ForeignSrcLang
lang :: ForeignSrcLang,

    -- | The contents of the file, which will be written to a temporary file
    -- when loaded from an interface.
    IfaceForeignFile -> String
source :: String,

    -- | The extension used by the user is preserved, to avoid confusing
    -- external tools with an unexpected @.c@ file or similar.
    IfaceForeignFile -> String
extension :: FilePath
  }

instance Outputable IfaceForeignFile where
  ppr :: IfaceForeignFile -> SDoc
ppr IfaceForeignFile {ForeignSrcLang
lang :: IfaceForeignFile -> ForeignSrcLang
lang :: ForeignSrcLang
lang, String
source :: IfaceForeignFile -> String
source :: String
source} =
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text (ForeignSrcLang -> String
forall a. Show a => a -> String
show ForeignSrcLang
lang) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> [String] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
lines String
source))

instance Binary IfaceForeignFile where
  get :: ReadBinHandle -> IO IfaceForeignFile
get ReadBinHandle
bh = do
    lang <- ReadBinHandle -> IO ForeignSrcLang
binary_get_ForeignSrcLang ReadBinHandle
bh
    source <- get bh
    extension <- get bh
    pure IfaceForeignFile {lang, source, extension}

  put_ :: WriteBinHandle -> IfaceForeignFile -> IO ()
put_ WriteBinHandle
bh IfaceForeignFile {ForeignSrcLang
lang :: IfaceForeignFile -> ForeignSrcLang
lang :: ForeignSrcLang
lang, String
source :: IfaceForeignFile -> String
source :: String
source, String
extension :: IfaceForeignFile -> String
extension :: String
extension} = do
    WriteBinHandle -> ForeignSrcLang -> IO ()
binary_put_ForeignSrcLang WriteBinHandle
bh ForeignSrcLang
lang
    WriteBinHandle -> String -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh String
source
    WriteBinHandle -> String -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh String
extension

instance NFData IfaceForeignFile where
  rnf :: IfaceForeignFile -> ()
rnf IfaceForeignFile {ForeignSrcLang
lang :: IfaceForeignFile -> ForeignSrcLang
lang :: ForeignSrcLang
lang, String
source :: IfaceForeignFile -> String
source :: String
source, String
extension :: IfaceForeignFile -> String
extension :: String
extension} =
    ForeignSrcLang
lang ForeignSrcLang -> () -> ()
forall a b. a -> b -> b
`seq` String -> ()
forall a. NFData a => a -> ()
rnf String
source () -> () -> ()
forall a b. a -> b -> b
`seq` String -> ()
forall a. NFData a => a -> ()
rnf String
extension

data IfaceForeign =
  IfaceForeign {
    IfaceForeign -> Maybe IfaceCStubs
stubs :: Maybe IfaceCStubs,
    IfaceForeign -> [IfaceForeignFile]
files :: [IfaceForeignFile]
  }

instance Outputable IfaceForeign where
  ppr :: IfaceForeign -> SDoc
ppr IfaceForeign {Maybe IfaceCStubs
stubs :: IfaceForeign -> Maybe IfaceCStubs
stubs :: Maybe IfaceCStubs
stubs, [IfaceForeignFile]
files :: IfaceForeign -> [IfaceForeignFile]
files :: [IfaceForeignFile]
files} =
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stubs:") Int
2 (SDoc -> (IfaceCStubs -> SDoc) -> Maybe IfaceCStubs -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"empty") IfaceCStubs -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe IfaceCStubs
stubs) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (IfaceForeignFile -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IfaceForeignFile -> SDoc) -> [IfaceForeignFile] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IfaceForeignFile]
files)

emptyIfaceForeign :: IfaceForeign
emptyIfaceForeign :: IfaceForeign
emptyIfaceForeign = IfaceForeign {stubs :: Maybe IfaceCStubs
stubs = Maybe IfaceCStubs
forall a. Maybe a
Nothing, files :: [IfaceForeignFile]
files = []}

-- | Convert foreign stubs and foreign files to a format suitable for writing to
-- interfaces.
--
-- See Note [Foreign stubs and TH bytecode linking]
encodeIfaceForeign ::
  Logger ->
  DynFlags ->
  ForeignStubs ->
  [(ForeignSrcLang, FilePath)] ->
  IO IfaceForeign
encodeIfaceForeign :: Logger
-> DynFlags
-> ForeignStubs
-> [(ForeignSrcLang, String)]
-> IO IfaceForeign
encodeIfaceForeign Logger
logger DynFlags
dflags ForeignStubs
foreign_stubs [(ForeignSrcLang, String)]
lang_paths = do
  files <- IO [IfaceForeignFile]
read_foreign_files
  stubs <- encode_stubs foreign_stubs
  let iff = IfaceForeign {Maybe IfaceCStubs
stubs :: Maybe IfaceCStubs
stubs :: Maybe IfaceCStubs
stubs, [IfaceForeignFile]
files :: [IfaceForeignFile]
files :: [IfaceForeignFile]
files}
  debugTraceMsg logger 3 $
    hang (text "Encoding foreign data for iface:") 2 (ppr iff)
  pure iff
  where
    -- We can't just store the paths, since files may have been generated with
    -- GHC session lifetime in 'GHC.Internal.TH.Syntax.addForeignSource'.
    read_foreign_files :: IO [IfaceForeignFile]
read_foreign_files =
      [(ForeignSrcLang, String)]
-> ((ForeignSrcLang, String) -> IO IfaceForeignFile)
-> IO [IfaceForeignFile]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(ForeignSrcLang, String)]
lang_paths (((ForeignSrcLang, String) -> IO IfaceForeignFile)
 -> IO [IfaceForeignFile])
-> ((ForeignSrcLang, String) -> IO IfaceForeignFile)
-> IO [IfaceForeignFile]
forall a b. (a -> b) -> a -> b
$ \ (ForeignSrcLang
lang, String
path) -> do
        source <- String -> IO String
readFile String
path
        pure IfaceForeignFile {lang, source, extension = takeExtension path}

    encode_stubs :: ForeignStubs -> IO (Maybe IfaceCStubs)
encode_stubs = \case
      ForeignStubs
NoStubs ->
        Maybe IfaceCStubs -> IO (Maybe IfaceCStubs)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IfaceCStubs
forall a. Maybe a
Nothing
      ForeignStubs (CHeader SDoc
header) (CStub SDoc
source [CLabel]
inits [CLabel]
finals) ->
        Maybe IfaceCStubs -> IO (Maybe IfaceCStubs)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe IfaceCStubs -> IO (Maybe IfaceCStubs))
-> Maybe IfaceCStubs -> IO (Maybe IfaceCStubs)
forall a b. (a -> b) -> a -> b
$ IfaceCStubs -> Maybe IfaceCStubs
forall a. a -> Maybe a
Just IfaceCStubs {
          header :: String
header = SDoc -> String
render SDoc
header,
          source :: String
source = SDoc -> String
render SDoc
source,
          initializers :: [IfaceCLabel]
initializers = CLabel -> IfaceCLabel
encode_label (CLabel -> IfaceCLabel) -> [CLabel] -> [IfaceCLabel]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CLabel]
inits,
          finalizers :: [IfaceCLabel]
finalizers = CLabel -> IfaceCLabel
encode_label (CLabel -> IfaceCLabel) -> [CLabel] -> [IfaceCLabel]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CLabel]
finals
        }

    encode_label :: CLabel -> IfaceCLabel
encode_label CLabel
clabel =
      IfaceCLabel -> Maybe IfaceCLabel -> IfaceCLabel
forall a. a -> Maybe a -> a
fromMaybe (CLabel -> IfaceCLabel
invalid_label CLabel
clabel) (CStubLabel -> IfaceCLabel
IfaceCLabel (CStubLabel -> IfaceCLabel)
-> Maybe CStubLabel -> Maybe IfaceCLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CLabel -> Maybe CStubLabel
cStubLabel CLabel
clabel)

    invalid_label :: CLabel -> IfaceCLabel
invalid_label CLabel
clabel =
      String -> SDoc -> IfaceCLabel
forall a. HasCallStack => String -> SDoc -> a
pprPanic
      String
"-fwrite-if-simplified-core is incompatible with this foreign stub:"
      (Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel (DynFlags -> Platform
targetPlatform DynFlags
dflags) CLabel
clabel)

    render :: SDoc -> String
render = SDocContext -> SDoc -> String
renderWithContext (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
PprCode)

-- | Decode serialized foreign stubs and foreign files.
--
-- See Note [Foreign stubs and TH bytecode linking]
decodeIfaceForeign ::
  Logger ->
  TmpFs ->
  TempDir ->
  IfaceForeign ->
  IO (ForeignStubs, [(ForeignSrcLang, FilePath)])
decodeIfaceForeign :: Logger
-> TmpFs
-> TempDir
-> IfaceForeign
-> IO (ForeignStubs, [(ForeignSrcLang, String)])
decodeIfaceForeign Logger
logger TmpFs
tmpfs TempDir
tmp_dir iff :: IfaceForeign
iff@IfaceForeign {Maybe IfaceCStubs
stubs :: IfaceForeign -> Maybe IfaceCStubs
stubs :: Maybe IfaceCStubs
stubs, [IfaceForeignFile]
files :: IfaceForeign -> [IfaceForeignFile]
files :: [IfaceForeignFile]
files} = do
  Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Decoding foreign data from iface:") Int
2 (IfaceForeign -> SDoc
forall a. Outputable a => a -> SDoc
ppr IfaceForeign
iff)
  lang_paths <- [IfaceForeignFile]
-> (IfaceForeignFile -> IO (ForeignSrcLang, String))
-> IO [(ForeignSrcLang, String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [IfaceForeignFile]
files ((IfaceForeignFile -> IO (ForeignSrcLang, String))
 -> IO [(ForeignSrcLang, String)])
-> (IfaceForeignFile -> IO (ForeignSrcLang, String))
-> IO [(ForeignSrcLang, String)]
forall a b. (a -> b) -> a -> b
$ \ IfaceForeignFile {ForeignSrcLang
lang :: IfaceForeignFile -> ForeignSrcLang
lang :: ForeignSrcLang
lang, String
source :: IfaceForeignFile -> String
source :: String
source, String
extension :: IfaceForeignFile -> String
extension :: String
extension} -> do
    f <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
TFL_GhcSession String
extension
    writeFile f source
    pure (lang, f)
  pure (maybe NoStubs decode_stubs stubs, lang_paths)
  where
    decode_stubs :: IfaceCStubs -> ForeignStubs
decode_stubs IfaceCStubs {String
header :: IfaceCStubs -> String
header :: String
header, String
source :: IfaceCStubs -> String
source :: String
source, [IfaceCLabel]
initializers :: IfaceCStubs -> [IfaceCLabel]
initializers :: [IfaceCLabel]
initializers, [IfaceCLabel]
finalizers :: IfaceCStubs -> [IfaceCLabel]
finalizers :: [IfaceCLabel]
finalizers} =
      CHeader -> CStub -> ForeignStubs
ForeignStubs
      (SDoc -> CHeader
CHeader (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
header))
      (SDoc -> [CLabel] -> [CLabel] -> CStub
CStub (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
source) ([IfaceCLabel] -> [CLabel]
labels [IfaceCLabel]
initializers) ([IfaceCLabel] -> [CLabel]
labels [IfaceCLabel]
finalizers))

    labels :: [IfaceCLabel] -> [CLabel]
labels [IfaceCLabel]
ls = [CStubLabel -> CLabel
fromCStubLabel CStubLabel
l | IfaceCLabel CStubLabel
l <- [IfaceCLabel]
ls]

instance Binary IfaceForeign where
  get :: ReadBinHandle -> IO IfaceForeign
get ReadBinHandle
bh = do
    stubs <- ReadBinHandle -> IO (Maybe IfaceCStubs)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
    files <- get bh
    pure IfaceForeign {stubs, files}

  put_ :: WriteBinHandle -> IfaceForeign -> IO ()
put_ WriteBinHandle
bh IfaceForeign {Maybe IfaceCStubs
stubs :: IfaceForeign -> Maybe IfaceCStubs
stubs :: Maybe IfaceCStubs
stubs, [IfaceForeignFile]
files :: IfaceForeign -> [IfaceForeignFile]
files :: [IfaceForeignFile]
files} = do
    WriteBinHandle -> Maybe IfaceCStubs -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Maybe IfaceCStubs
stubs
    WriteBinHandle -> [IfaceForeignFile] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh [IfaceForeignFile]
files

instance NFData IfaceForeign where
  rnf :: IfaceForeign -> ()
rnf IfaceForeign {Maybe IfaceCStubs
stubs :: IfaceForeign -> Maybe IfaceCStubs
stubs :: Maybe IfaceCStubs
stubs, [IfaceForeignFile]
files :: IfaceForeign -> [IfaceForeignFile]
files :: [IfaceForeignFile]
files} = Maybe IfaceCStubs -> ()
forall a. NFData a => a -> ()
rnf Maybe IfaceCStubs
stubs () -> () -> ()
forall a b. a -> b -> b
`seq` [IfaceForeignFile] -> ()
forall a. NFData a => a -> ()
rnf [IfaceForeignFile]
files