-- | Foreign export stubs
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Types.ForeignStubs
   ( ForeignStubs (..)
   , CHeader(..)
   , CStub(..)
   , initializerCStub
   , finalizerCStub
   , appendStubC
   )
where

import {-# SOURCE #-} GHC.Cmm.CLabel

import GHC.Platform
import GHC.Utils.Outputable
import Data.List ((++))
import Data.Monoid
import Data.Semigroup
import Data.Coerce

data CStub = CStub { CStub -> SDoc
getCStub :: SDoc
                   , CStub -> [CLabel]
getInitializers :: [CLabel]
                     -- ^ Initializers to be run at startup
                     -- See Note [Initializers and finalizers in Cmm] in
                     -- "GHC.Cmm.InitFini".
                   , CStub -> [CLabel]
getFinalizers :: [CLabel]
                     -- ^ Finalizers to be run at shutdown
                   }

emptyCStub :: CStub
emptyCStub :: CStub
emptyCStub = SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
forall doc. IsOutput doc => doc
empty [] []

instance Monoid CStub where
  mempty :: CStub
mempty = CStub
emptyCStub

instance Semigroup CStub where
  CStub SDoc
a0 [CLabel]
b0 [CLabel]
c0 <> :: CStub -> CStub -> CStub
<> CStub SDoc
a1 [CLabel]
b1 [CLabel]
c1 =
      SDoc -> [CLabel] -> [CLabel] -> CStub
CStub (SDoc
a0 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
a1) ([CLabel]
b0 [CLabel] -> [CLabel] -> [CLabel]
forall a. [a] -> [a] -> [a]
++ [CLabel]
b1) ([CLabel]
c0 [CLabel] -> [CLabel] -> [CLabel]
forall a. [a] -> [a] -> [a]
++ [CLabel]
c1)

functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body =
    SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
body' [] []
  where
    body' :: SDoc
body' = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
        [ SDoc
declarations
        , [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void", Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
clbl, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(void)"]
        , SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces SDoc
body
        ]

-- | @initializerCStub fn_nm decls body@ is a 'CStub' containing C initializer
-- function (e.g. an entry of the @.init_array@ section) named
-- @fn_nm@ with the given body and the given set of declarations.
initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body =
    Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
    CStub -> CStub -> CStub
forall a. Monoid a => a -> a -> a
`mappend` SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
forall doc. IsOutput doc => doc
empty [CLabel
clbl] []

-- | @finalizerCStub fn_nm decls body@ is a 'CStub' containing C finalizer
-- function (e.g. an entry of the @.fini_array@ section) named
-- @fn_nm@ with the given body and the given set of declarations.
--
-- See Note [Finalizers via __cxa_atexit]
finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
finalizerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
  | Arch
ArchWasm32 <- Platform -> Arch
platformArch Platform
platform
  = -- See Note [Finalizers via __cxa_atexit]
    Platform -> CLabel -> SDoc -> SDoc -> CStub
cxaAtexitFinalizerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
finalizerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
  | OS
OSDarwin <- Platform -> OS
platformOS Platform
platform
  = -- See Note [Finalizers via __cxa_atexit]
    Platform -> CLabel -> SDoc -> SDoc -> CStub
cxaAtexitFinalizerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
finalizerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
  = Platform -> CLabel -> SDoc -> SDoc -> CStub
functionCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body
    CStub -> CStub -> CStub
forall a. Monoid a => a -> a -> a
`mappend` SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
forall doc. IsOutput doc => doc
empty [] [CLabel
clbl]

-- | Generate a @__cxa_atexit@-based finalizer.
-- See Note [Finalizers via __cxa_atexit]
cxaAtexitFinalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
cxaAtexitFinalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub
cxaAtexitFinalizerCStub Platform
platform CLabel
clbl SDoc
declarations SDoc
body =
    let clbl_pretty :: SDoc
clbl_pretty = Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
clbl
        fini_name :: SDoc
fini_name    = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [SDoc
clbl_pretty, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"$fini"]
        wrapper_name :: SDoc
wrapper_name = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [SDoc
clbl_pretty, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"$fini_atexit"]
        c_code :: SDoc
c_code = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
          [ SDoc
declarations
          , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"int __cxa_atexit(void (*)(void *), void *, void *);"
          , [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"static void ", SDoc
fini_name, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(void)"]
          , SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces SDoc
body
          , [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"static void ", SDoc
wrapper_name, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(void *arg __attribute__((unused)))"]
          , SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [SDoc
fini_name, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"();"])
          , [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void", SDoc
clbl_pretty, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(void)"]
          , SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__cxa_atexit(", SDoc
wrapper_name, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", 0, 0);"])
          ]
    in SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
c_code [CLabel
clbl] []

{-
Note [Finalizers via __cxa_atexit]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On some platforms, placing a function pointer in the .fini_array /
__mod_term_func section is not sufficient to have it called on exit.
On these platforms we instead lower finalizers as initializers that register
the actual finalizer function via __cxa_atexit.

Affected platforms:

  Wasm32: does not support .fini_array sections.

  Darwin: modern macOS dyld no longer processes __DATA,__mod_term_func entries.
  Clang now lowers __attribute__((destructor)) as an initializer that calls
  __cxa_atexit, placing the initializer in __DATA,__mod_init_func (which the
  linker converts to __TEXT,__init_offsets). GHC must follow the same pattern.

For a finalizer with label `clbl` and body `body`, on these platforms we
generate:

    static void clbl$fini(void) {
        <body>
    }
    static void clbl$fini_atexit(void *arg) {
        clbl$fini();
    }
    void clbl(void) {
        __cxa_atexit(clbl$fini_atexit, 0, 0);
    }

The function `clbl` is placed in the initializers list (getInitializers)
instead of the finalizers list (getFinalizers). During code output,
emitInitializerDecls places it in .init_array / __mod_init_func, so the
registration runs at startup.

The actual finalizer body is in the static helper `clbl$fini`. A separate
wrapper `clbl$fini_atexit` with the void(*)(void*) signature expected by
__cxa_atexit is needed because some platforms (e.g. wasm32) enforce exact
function signature matching at call sites — a simple cast would trap at
runtime.

This matches what clang does when lowering __attribute__((destructor)) on
these platforms.
-}

newtype CHeader = CHeader { CHeader -> SDoc
getCHeader :: SDoc }

instance Monoid CHeader where
  mempty :: CHeader
mempty = SDoc -> CHeader
CHeader SDoc
forall doc. IsOutput doc => doc
empty
  mconcat :: [CHeader] -> CHeader
mconcat = ([SDoc] -> SDoc) -> [CHeader] -> CHeader
forall a b. Coercible a b => a -> b
coerce (forall doc. IsDoc doc => [doc] -> doc
vcat @SDoc)

instance Semigroup CHeader where
    <> :: CHeader -> CHeader -> CHeader
(<>) = (SDoc -> SDoc -> SDoc) -> CHeader -> CHeader -> CHeader
forall a b. Coercible a b => a -> b
coerce (forall doc. IsDoc doc => doc -> doc -> doc
($$) @SDoc)

-- | Foreign export stubs
data ForeignStubs
  = NoStubs
      -- ^ We don't have any stubs
  | ForeignStubs CHeader CStub
      -- ^ There are some stubs. Parameters:
      --
      --  1) Header file prototypes for
      --     "foreign exported" functions
      --
      --  2) C stubs to use when calling
      --     "foreign exported" functions

appendStubC :: ForeignStubs -> CStub -> ForeignStubs
appendStubC :: ForeignStubs -> CStub -> ForeignStubs
appendStubC ForeignStubs
NoStubs         CStub
c_code = CHeader -> CStub -> ForeignStubs
ForeignStubs CHeader
forall a. Monoid a => a
mempty CStub
c_code
appendStubC (ForeignStubs CHeader
h CStub
c) CStub
c_code = CHeader -> CStub -> ForeignStubs
ForeignStubs CHeader
h (CStub
c CStub -> CStub -> CStub
forall a. Monoid a => a -> a -> a
`mappend` CStub
c_code)