{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module GHC.HsToCore.Foreign.Wasm
  ( dsWasmJSImport,
    dsWasmJSExport,
  )
where

import Data.List
  ( intercalate,
    stripPrefix,
  )
import Data.Maybe
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Core
import GHC.Core.Coercion
import GHC.Core.DataCon
import GHC.Core.Make
import GHC.Core.Multiplicity
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Utils
import GHC.Data.FastString
import GHC.Hs
import GHC.HsToCore.Foreign.Call
import GHC.HsToCore.Foreign.Utils
import GHC.HsToCore.Monad
import GHC.HsToCore.Types
import GHC.Iface.Env
import GHC.Prelude
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import GHC.Types.ForeignCall
import GHC.Types.ForeignStubs
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Types.Var
import GHC.Unit
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Language.Haskell.Syntax.Basic

dsWasmJSImport ::
  Id ->
  Coercion ->
  CImportSpec ->
  Safety ->
  DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSImport :: Id
-> Coercion
-> CImportSpec
-> Safety
-> DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSImport Id
id Coercion
co (CFunction (StaticTarget SourceText
_ FastString
js_src Maybe Unit
mUnitId Bool
_)) Safety
safety
  | FastString
js_src FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"wrapper" = Id
-> Coercion -> Maybe Unit -> DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSDynamicExport Id
id Coercion
co Maybe Unit
mUnitId
  | Bool
otherwise = do
      (bs, h, c) <- Id
-> Coercion
-> [Char]
-> Maybe Unit
-> Safety
-> DsM ([Binding], CHeader, CStub)
dsWasmJSStaticImport Id
id Coercion
co (FastString -> [Char]
unpackFS FastString
js_src) Maybe Unit
mUnitId Safety
safety
      pure (bs, h, c, [])
dsWasmJSImport Id
_ Coercion
_ CImportSpec
_ Safety
_ = [Char] -> DsM ([Binding], CHeader, CStub, [Id])
forall a. HasCallStack => [Char] -> a
panic [Char]
"dsWasmJSImport: unreachable"

{-

Note [Desugaring JSFFI dynamic export]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

A JSFFI dynamic export wraps a Haskell function as a JavaScript
callback:

foreign import javascript "wrapper"
  mk_wrapper :: HsFuncType -> IO JSVal

We desugar it to three bindings under the hood:

1. The worker function

mk_wrapper_worker :: StablePtr HsFuncType -> HsFuncType
mk_wrapper_worker sp = unsafeDupablePerformIO (deRefStablePtr sp)

No need to bother with eta-expansion here. Also, the worker function
is marked as a JSFFI static export.

2. The adjustor function

foreign import javascript unsafe "(...args) => __exports.mk_wrapper_worker($1, ...args)"
  mk_wrapper_adjustor :: StablePtr HsFuncType -> IO JSVal

It generates a JavaScript callback that captures the stable pointer.
When the callback is invoked later, it calls our worker function and
passes the stable pointer as well as the rest of the arguments.

3. The wrapper function

mk_wrapper :: HsFuncType -> IO JSVal
mk_wrapper = mkJSCallback mk_wrapper_adjustor

This is the user-facing mk_wrapper binding. It allocates a stable
pointer for the Haskell function closure, then calls the adjustor
function to fetch the JSVal that represents the JavaScript callback.
The JSVal as returned by the adjustor is not returned directly; it has
a StablePtr# field which is NULL by default, but for JSFFI dynamic
exports, it's set to the Haskell function's stable pointer. This way,
when we call freeJSVal, the Haskell function can be freed as well.

-}

dsWasmJSDynamicExport ::
  Id -> Coercion -> Maybe Unit -> DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSDynamicExport :: Id
-> Coercion -> Maybe Unit -> DsM ([Binding], CHeader, CStub, [Id])
dsWasmJSDynamicExport Id
fn_id Coercion
co Maybe Unit
mUnitId = do
  sp_tycon <- Name -> DsM TyCon
dsLookupTyCon Name
stablePtrTyConName
  let ty = Coercion -> Type
coercionLKind Coercion
co
      (tv_bndrs, fun_ty) = tcSplitForAllTyVarBinders ty
      ([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty
      sp_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
sp_tycon [Type
arg_ty]
      (real_arg_tys, _) = tcSplitFunTys arg_ty
  sp_id <- newSysLocalDs ManyTy sp_ty
  work_uniq <- newUnique
  work_export_name <- uniqueCFunName
  deRefStablePtr_id <- lookupGhcInternalVarId "GHC.Internal.Stable" "deRefStablePtr"
  unsafeDupablePerformIO_id <-
    lookupGhcInternalVarId
      "GHC.Internal.IO.Unsafe"
      "unsafeDupablePerformIO"
  let work_id =
        Name -> Type -> Id
mkExportedVanillaId
          ( Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName
              Unique
work_uniq
              (HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
getName Id
fn_id)
              ([Char] -> OccName
mkVarOcc ([Char] -> OccName) -> [Char] -> OccName
forall a b. (a -> b) -> a -> b
$ [Char]
"jsffi_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OccName -> [Char]
occNameString (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
fn_id) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_work")
              SrcSpan
generatedSrcSpan
          )
          Type
work_ty
      work_rhs =
        [Id] -> CoreExpr -> CoreExpr
mkCoreLams ([Id
tv | Bndr Id
tv ForAllTyFlag
_ <- [TyVarBinder]
tv_bndrs] [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
sp_id])
          (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
            (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unsafeDupablePerformIO_id)
            [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
deRefStablePtr_id) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
sp_id]]
      work_ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
work_rhs
  (work_h, work_c, _, _, work_ids, work_bs) <-
    dsWasmJSExport
      work_id
      (mkRepReflCo work_ty)
      work_export_name
  adjustor_uniq <- newUnique
  let adjustor_id =
        Name -> Type -> Id
mkExportedVanillaId
          ( Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName
              Unique
adjustor_uniq
              (HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
getName Id
fn_id)
              ( [Char] -> OccName
mkVarOcc
                  ([Char] -> OccName) -> [Char] -> OccName
forall a b. (a -> b) -> a -> b
$ [Char]
"jsffi_"
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OccName -> [Char]
occNameString (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
fn_id)
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_adjustor"
              )
              SrcSpan
generatedSrcSpan
          )
          Type
adjustor_ty
      adjustor_ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tv_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
mkVisFunTysMany [Type
sp_ty] Type
io_jsval_ty
      adjustor_js_src =
        [Char]
"("
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"a" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | Int
i <- [Int
1 .. [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
real_arg_tys]]
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") => __exports."
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FastString -> [Char]
unpackFS FastString
work_export_name
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"($1"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat [[Char]
",a" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | Int
i <- [Int
1 .. [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
real_arg_tys]]
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  (adjustor_bs, adjustor_h, adjustor_c) <-
    dsWasmJSStaticImport
      adjustor_id
      (mkRepReflCo adjustor_ty)
      adjustor_js_src
      mUnitId
      PlayRisky
  mkJSCallback_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "mkJSCallback"
  let wrap_rhs =
        [Id] -> CoreExpr -> CoreExpr
mkCoreLams [Id
tv | Bndr Id
tv ForAllTyFlag
_ <- [TyVarBinder]
tv_bndrs]
          (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
            (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
mkJSCallback_id)
            [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty,
              CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
                (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
adjustor_id)
                [Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> Type -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> Type
mkTyVarTy Id
tv | Bndr Id
tv ForAllTyFlag
_ <- [TyVarBinder]
tv_bndrs]
            ]
  pure
    ( [(fn_id, Cast wrap_rhs co), (work_id, work_rhs)] ++ work_bs ++ adjustor_bs,
      work_h `mappend` adjustor_h,
      work_c `mappend` adjustor_c,
      work_ids
    )

{-

Note [Desugaring JSFFI import]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The simplest case is JSFFI sync import, those marked as unsafe. It is
implemented on top of C FFI unsafe import.

Unlike C FFI which generates a worker/wrapper pair that unboxes the
arguments and boxes the result in Haskell, we only desugar to a single
Haskell binding that case-binds the arguments to ensure they're
evaluated, then passes the boxed arguments directly to C and receive
the boxed result from C as well.

This is of course less efficient than how C FFI does it, and unboxed
FFI types aren't supported, but it's the easiest way to implement it,
especially since leaving all the boxing/unboxing business to C unifies
the implementation of JSFFI imports and exports.

Now, each sync import calls a generated C function with a unique
symbol. The C function uses rts_get* to unbox the arguments, call into
JavaScript, then boxes the result with rts_mk* and returns it to
Haskell. But wait, how on earth is C able to call into JavaScript
here!? The secret is using a wasm import:

__attribute__((import_module("ghc_wasm_jsffi"), import_name("my_js_func")))
HsJSVal worker_func(HsInt a1, HsJSVal a2);

Wasm imports live in the same namespace as other wasm functions, so
our C wrapper function can call into this imported worker function,
which will literally be the user written JavaScript function with
binders $1, $2, etc.

So far so good, but how does the source code snippet go from Haskell
source files to the JavaScript module which provides the
ghc_wasm_jsffi imports to be used by the wasm module at runtime? The
secret is embedding the source code snippets in a wasm custom section
named ghc_wasm_jsffi:

.section .custom_section.ghc_wasm_jsffi,"",@
.asciz my_js_func
.asciz ($1, $2)
.asciz js_code_containing($1, $2)

At link time, for all object files touched by wasm-ld, all
ghc_wasm_jsffi sections are concatenated into a single ghc_wasm_jsffi
section in the output wasm module. And then, a simple "post-linker"
program can parse the payload of that section and emit a JavaScript
module. Note that above is assembly source file, but we're only
generating a C stub, so we need to smuggle the assembly code into C
via __asm__.

JSFFI async import is implemented on top of JSFFI sync import. We
still desugar it to a single Haskell binding that calls C, with some
subtle differences:

- The C result type is always a boxed JSVal that represents the
  JavaScript Promise, instead of the actual Haskell result type.
- In the custom section payload, we emit "async ($1, $2)" instead of
  "($1, $2)". As you can see, it is the arrow function binder, and the
  post-linker will respect the async binder and allow await in the
  function body.
- The C import is also marked as safe. This is required since the
  JavaScript code may re-enter Haskell. If re-entrance only happens in
  future event loop tasks, it's fine to mark the C import as unsafe
  since the current Haskell execution context has already been freed
  at that point, but there's no such guarantee, so better safe than
  sorry here.

Now we have the Promise JSVal, we apply stg_blockPromise to it to get
a thunk with the desired return type. When the thunk is forced, it
will block the forcing thread and wait for the Promise to resolve or
reject. See Note [stg_blockPromise] for detailed explanation of how it
works.

-}

dsWasmJSStaticImport ::
  Id ->
  Coercion ->
  String ->
  Maybe Unit ->
  Safety ->
  DsM ([Binding], CHeader, CStub)
dsWasmJSStaticImport :: Id
-> Coercion
-> [Char]
-> Maybe Unit
-> Safety
-> DsM ([Binding], CHeader, CStub)
dsWasmJSStaticImport Id
fn_id Coercion
co [Char]
js_src' Maybe Unit
mUnitId Safety
safety = do
  cfun_name <- DsM FastString
uniqueCFunName
  let ty = Coercion -> Type
coercionLKind Coercion
co
      (tvs, fun_ty) = tcSplitForAllInvisTyVars ty
      (arg_tys, orig_res_ty) = tcSplitFunTys fun_ty
      (res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of
        Just (TyCon
_, Type
res_ty) -> (Type
res_ty, Bool
True)
        Maybe (TyCon, Type)
Nothing -> (Type
orig_res_ty, Bool
False)
      js_src
        -- Just desugar it to a JSFFI import with source text "$1($2,
        -- ...)", with the same type signature and safety annotation.
        | [Char]
js_src' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"dynamic" =
            [Char]
"$1("
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | Int
i <- [Int
2 .. [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
arg_tys]]
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
        | Bool
otherwise =
            [Char]
js_src'
  case safety of
    Safety
PlayRisky -> do
      rhs <-
        Maybe Unit
-> Safety
-> FastString
-> [Id]
-> [Scaled Type]
-> Type
-> (CoreExpr -> CoreExpr)
-> DsM CoreExpr
importBindingRHS
          Maybe Unit
mUnitId
          Safety
PlayRisky
          FastString
cfun_name
          [Id]
tvs
          [Scaled Type]
arg_tys
          Type
orig_res_ty
          CoreExpr -> CoreExpr
forall a. a -> a
id
      pure
        ( [(fn_id, Cast rhs co)],
          CHeader commonCDecls,
          importCStub
            PlayRisky
            cfun_name
            (map scaledThing arg_tys)
            res_ty
            js_src
        )
    Safety
_ -> do
      io_tycon <- Name -> DsM TyCon
dsLookupTyCon Name
ioTyConName
      jsval_ty <- mkTyConTy <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal"
      bindIO_id <- dsLookupGlobalId bindIOName
      returnIO_id <- dsLookupGlobalId returnIOName
      promise_id <- newSysLocalDs ManyTy jsval_ty
      blockPromise_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" "stg_blockPromise"
      msgPromise_id <-
        lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Imports" $ "stg_messagePromise" ++ ffiType res_ty
      unsafeDupablePerformIO_id <-
        lookupGhcInternalVarId
          "GHC.Internal.IO.Unsafe"
          "unsafeDupablePerformIO"
      rhs <-
        importBindingRHS
          mUnitId
          PlaySafe
          cfun_name
          tvs
          arg_tys
          (mkTyConApp io_tycon [jsval_ty])
          $ ( if is_io
                then id
                else \CoreExpr
m_res ->
                  CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unsafeDupablePerformIO_id) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty, CoreExpr
m_res]
            )
          -- (m_promise :: IO JSVal) >>= (\promise -> return (stg_blockPromise promise msgPromise))
          -- stg_blockPromise returns the thunk
          . ( \CoreExpr
m_promise ->
                CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
                  (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bindIO_id)
                  [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
jsval_ty,
                    Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty,
                    CoreExpr
m_promise,
                    Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
promise_id
                      (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
                        (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
returnIO_id)
                        [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty,
                          CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
                            (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
blockPromise_id)
                            [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
promise_id, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
msgPromise_id]
                        ]
                  ]
            )
      pure
        ( [(fn_id, Cast rhs co)],
          CHeader commonCDecls,
          importCStub
            PlaySafe
            cfun_name
            (map scaledThing arg_tys)
            jsval_ty
            js_src
        )

uniqueCFunName :: DsM FastString
uniqueCFunName :: DsM FastString
uniqueCFunName = do
  cfun_num <- DsGblEnv -> IORef (ModuleEnv Int)
ds_next_wrapper_num (DsGblEnv -> IORef (ModuleEnv Int))
-> IOEnv (Env DsGblEnv DsLclEnv) DsGblEnv
-> IOEnv (Env DsGblEnv DsLclEnv) (IORef (ModuleEnv Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  mkWrapperName cfun_num "ghc_wasm_jsffi" ""

importBindingRHS ::
  Maybe Unit ->
  Safety ->
  FastString ->
  [TyVar] ->
  [Scaled Type] ->
  Type ->
  (CoreExpr -> CoreExpr) ->
  DsM CoreExpr
importBindingRHS :: Maybe Unit
-> Safety
-> FastString
-> [Id]
-> [Scaled Type]
-> Type
-> (CoreExpr -> CoreExpr)
-> DsM CoreExpr
importBindingRHS Maybe Unit
mUnitId Safety
safety FastString
cfun_name [Id]
tvs [Scaled Type]
arg_tys Type
orig_res_ty CoreExpr -> CoreExpr
res_trans =
  do
    ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    args_unevaled <- newSysLocalsDs arg_tys
    args_evaled <- newSysLocalsDs arg_tys
    -- ccall_action_ty: type of the_call, State# RealWorld -> (# State# RealWorld, a #)
    -- res_wrapper: turn the_call to (IO a) or a
    (ccall_action_ty, res_wrapper) <- case tcSplitIOType_maybe orig_res_ty of
      Just (TyCon
io_tycon, Type
res_ty) -> do
        s0_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
        s1_id <- newSysLocalDs ManyTy realWorldStatePrimTy
        let io_data_con = TyCon -> DataCon
tyConSingleDataCon TyCon
io_tycon
            toIOCon = DataCon -> Id
dataConWorkId DataCon
io_data_con
            (ccall_res_ty, wrap)
              | res_ty `eqType` unitTy =
                  ( mkTupleTy Unboxed [realWorldStatePrimTy],
                    \CoreExpr
the_call ->
                      CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
                        (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
toIOCon)
                        [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty,
                          Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
s0_id
                            (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase
                              (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
s0_id))
                              (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
                              (Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
unitTy])
                              [ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt
                                  (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
1))
                                  [Id
s1_id]
                                  ([CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
s1_id, CoreExpr
unitExpr])
                              ]
                        ]
                  )
              | otherwise =
                  ( mkTupleTy Unboxed [realWorldStatePrimTy, res_ty],
                    \CoreExpr
the_call -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
toIOCon) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty, CoreExpr
the_call]
                  )
        pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
      Maybe (TyCon, Type)
Nothing -> do
        unsafeDupablePerformIO_id <-
          FastString -> [Char] -> DsM Id
lookupGhcInternalVarId
            FastString
"GHC.Internal.IO.Unsafe"
            [Char]
"unsafeDupablePerformIO"
        io_data_con <- dsLookupDataCon ioDataConName
        let ccall_res_ty =
              Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
orig_res_ty]
            toIOCon = DataCon -> Id
dataConWorkId DataCon
io_data_con
            wrap CoreExpr
the_call =
              CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
                (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unsafeDupablePerformIO_id)
                [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
orig_res_ty,
                  CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
toIOCon) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
orig_res_ty, CoreExpr
the_call]
                ]
        pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
    let cfun_fcall =
          CCallSpec -> ForeignCall
CCall
            ( CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec
                (SourceText -> FastString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText FastString
cfun_name Maybe Unit
mUnitId Bool
True)
                CCallConv
CCallConv
                Safety
safety
            )
        call_app =
          Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
ccall_uniq ForeignCall
cfun_fcall ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
args_evaled) Type
ccall_action_ty
        rhs =
          [Id] -> CoreExpr -> CoreExpr
mkCoreLams ([Id]
tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
args_unevaled)
            (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ ((Id, Id) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [(Id, Id)] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
              (\(Id
arg_u, Id
arg_e) CoreExpr
acc -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_u) Id
arg_e CoreExpr
acc)
              -- res_trans transforms the result. When desugaring
              -- JSFFI sync imports, the result is just (IO a) or a,
              -- and res_trans is id; for async cases, the result is
              -- always (IO JSVal), and res_trans will wrap it in a
              -- thunk that has the original return type. This way, we
              -- can reuse most of the RHS generation logic for both
              -- sync/async imports.
              (CoreExpr -> CoreExpr
res_trans (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
res_wrapper CoreExpr
call_app)
              ([Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
args_unevaled [Id]
args_evaled)
    pure rhs

importCStub :: Safety -> FastString -> [Type] -> Type -> String -> CStub
importCStub :: Safety -> FastString -> [Type] -> Type -> [Char] -> CStub
importCStub Safety
safety FastString
cfun_name [Type]
arg_tys Type
res_ty [Char]
js_src = SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
c_doc [] []
  where
    import_name :: [Char]
import_name = Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"ghczuwasmzujsffi" (FastString -> [Char]
unpackFS FastString
cfun_name)
    import_asm :: SDoc
import_asm =
      [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"__asm__"
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
          ( [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
              [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
l)
                | [Char]
l <-
                    [ [Char]
".section .custom_section.ghc_wasm_jsffi,\"\",@\n",
                      [Char]
".asciz \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
import_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\"\n",
                      [Char]
".asciz \""
                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ( case Safety
safety of
                               Safety
PlayRisky -> [Char]
"("
                               Safety
_ -> [Char]
"async ("
                           )
                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i | Int
i <- [Int
1 .. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
arg_tys]]
                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")\"\n",
                      [Char]
".asciz " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
js_src [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                    ]
              ]
          )
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
    import_attr :: SDoc
import_attr =
      [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"__attribute__"
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
          ( SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
              ( [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
                  ( SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate
                      SDoc
forall doc. IsLine doc => doc
comma
                      [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
v))
                        | ([Char]
k, [Char]
v) <-
                            [([Char]
"import_module", [Char]
"ghc_wasm_jsffi"), ([Char]
"import_name", [Char]
import_name)]
                      ]
                  )
              )
          )
    import_proto :: SDoc
import_proto =
      SDoc
import_res_ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
import_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
import_args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
    import_res_ty :: SDoc
import_res_ty
      | Type
res_ty Type -> Type -> Bool
`eqType` Type
unitTy = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
      | Bool
otherwise = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"Hs" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType Type
res_ty)
    import_arg_list :: [SDoc]
import_arg_list =
      [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"Hs" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType Type
arg_ty) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i
        | (Int
i, Type
arg_ty) <- [Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Type]
arg_tys
      ]
    import_args :: SDoc
import_args = case [SDoc]
import_arg_list of
      [] -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
      [SDoc]
_ -> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
import_arg_list
    cfun_proto :: SDoc
cfun_proto = SDoc
cfun_res_ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
cfun_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
cfun_args
    cfun_ret :: SDoc
cfun_ret
      | Type
res_ty Type -> Type -> Bool
`eqType` Type
unitTy = SDoc
cfun_call_import SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
      | Bool
otherwise = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"return" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cfun_call_import SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
    cfun_make_arg :: Type -> doc -> doc
cfun_make_arg Type
arg_ty doc
arg_val =
      [Char] -> doc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"rts_get" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType Type
arg_ty) doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> doc -> doc
forall doc. IsLine doc => doc -> doc
parens doc
arg_val
    cfun_make_ret :: SDoc -> SDoc
cfun_make_ret SDoc
ret_val
      | Type
res_ty Type -> Type -> Bool
`eqType` Type
unitTy = SDoc
ret_val
      | Bool
otherwise =
          [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"rts_mk" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType Type
res_ty)
            -- We can cheat a little bit here since there's only
            -- MainCapability in the single-threaded RTS anyway, so no
            -- need to call rts_unsafeGetMyCapability().
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"&MainCapability", SDoc
ret_val]))
    cfun_call_import :: SDoc
cfun_call_import =
      SDoc -> SDoc
cfun_make_ret
        (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
import_name
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
          ( [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
              ( SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate
                  SDoc
forall doc. IsLine doc => doc
comma
                  [ Type -> SDoc -> SDoc
forall {doc}. IsLine doc => Type -> doc -> doc
cfun_make_arg Type
arg_ty (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n)
                    | (Type
arg_ty, Int
n) <- [Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_tys [Int
1 ..]
                  ]
              )
          )
    cfun_res_ty :: SDoc
cfun_res_ty
      | Type
res_ty Type -> Type -> Bool
`eqType` Type
unitTy = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
      | Bool
otherwise = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HaskellObj"
    cfun_arg_list :: [SDoc]
cfun_arg_list =
      [[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HaskellObj" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n | Int
n <- [Int
1 .. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
arg_tys]]
    cfun_args :: SDoc
cfun_args = case [SDoc]
cfun_arg_list of
      [] -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
      [SDoc]
_ -> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
cfun_arg_list
    c_doc :: SDoc
c_doc =
      SDoc
commonCDecls
        SDoc -> SDoc -> SDoc
$+$ SDoc
import_asm
        SDoc -> SDoc -> SDoc
$+$ SDoc
import_attr
        SDoc -> SDoc -> SDoc
$+$ SDoc
import_proto
        SDoc -> SDoc -> SDoc
$+$ SDoc
cfun_proto
        SDoc -> SDoc -> SDoc
$+$ SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces SDoc
cfun_ret

{-

Note [Desugaring JSFFI static export]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

A JSFFI static export wraps a top-level Haskell binding as a wasm
module export that can be called in JavaScript as an async function:

foreign export javascript "plus"
  (+) :: Int -> Int -> Int

Just like generating C stub for a JSFFI import, we need to generate C
stub for a JSFFI export as well:

__attribute__((export_name("plus")))
HsJSVal plus(HsInt a1, HsInt a2) { ... }

At link time, you need to pass -optl-Wl,--export=plus,--export=... to
specify your entrypoint function symbols as roots of wasm-ld link-time
garbage collection. As for the auto-generated exports when desugaring
the JSFFI dynamic exports, they will be transitively included as well
due to the export_name attribute.

For each JSFFI static export, we create an internal worker function
which takes the same arguments as the exported Haskell binding, but
always returns (IO JSVal). Its RHS simply applies the arguments to the
original binding, then applies a runIO/runNonIO top handler function
to the result. The top handler creates a JavaScript Promise that
stands for Haskell evaluation result, schedules Haskell computation to
happen, and the Promise will eventually be resolved with the result or
rejected with an exception. That Promise is what we return in the C
stub function. See Note [Async JSFFI scheduler] for detailed
explanation.

There's nothing else to explain about the C stub function body; just
like C FFI exports, it calls rts_mk* to box the arguments, rts_apply
to apply them to the worker function, evaluates the result, then
unboxes the resulting Promise using rts_getJSVal and returns it.

Now, in JavaScript, once the wasm instance is initialized, you can
directly call these exports and await them, as if they're real
JavaScript async functions.

-}

dsWasmJSExport ::
  Id ->
  Coercion ->
  CLabelString ->
  DsM (CHeader, CStub, String, Int, [Id], [Binding])
dsWasmJSExport :: Id
-> Coercion
-> FastString
-> DsM (CHeader, CStub, [Char], Int, [Id], [Binding])
dsWasmJSExport Id
fn_id Coercion
co FastString
ext_name = do
  work_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
  let ty = Coercion -> Type
coercionRKind Coercion
co
      (tvs, fun_ty) = tcSplitForAllInvisTyVars ty
      (arg_tys, orig_res_ty) = tcSplitFunTys fun_ty
      (res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of
        Just (TyCon
_, Type
res_ty) -> (Type
res_ty, Bool
True)
        Maybe (TyCon, Type)
Nothing -> (Type
orig_res_ty, Bool
False)
      (_, res_ty_args) = splitTyConApp res_ty
      res_ty_str = Type -> [Char]
ffiType Type
res_ty
  args <- newSysLocalsDs arg_tys
  promiseRes_id <-
    lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" $ "js_promiseResolve" ++ res_ty_str
  runIO_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "runIO"
  runNonIO_id <- lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" "runNonIO"
  let work_id =
        Name -> Type -> Id
mkExportedVanillaId
          ( Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName
              Unique
work_uniq
              (HasDebugCallStack => Name -> Module
Name -> Module
nameModule (Name -> Module) -> Name -> Module
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
getName Id
fn_id)
              ([Char] -> OccName
mkVarOcc ([Char] -> OccName) -> [Char] -> OccName
forall a b. (a -> b) -> a -> b
$ [Char]
"jsffi_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ OccName -> [Char]
occNameString (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
fn_id))
              SrcSpan
generatedSrcSpan
          )
          (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
work_rhs)
      work_rhs =
        [Id] -> CoreExpr -> CoreExpr
mkCoreLams ([Id]
tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
args)
          (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps
            (Id -> CoreExpr
forall b. Id -> Expr b
Var (Id -> CoreExpr) -> Id -> CoreExpr
forall a b. (a -> b) -> a -> b
$ if Bool
is_io then Id
runIO_id else Id
runNonIO_id)
            [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty,
              CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
promiseRes_id) ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
res_ty_args,
              CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fn_id) Coercion
co)
                ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> (Id -> Type) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
mkTyVarTy) [Id]
tvs
                [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
args
            ]
      work_closure = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
work_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"_closure"
      work_closure_decl = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"extern StgClosure" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
work_closure SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
      cstub_attr =
        [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"__attribute__"
          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
            (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"export_name" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
ext_name))
      cstub_arg_list =
        [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"Hs" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i
          | (Int
i, Scaled Type
arg_ty) <- [Int] -> [Scaled Type] -> [(Int, Scaled Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Scaled Type]
arg_tys
        ]
      cstub_args = case [SDoc]
cstub_arg_list of
        [] -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"void"
        [SDoc]
_ -> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
cstub_arg_list
      cstub_proto = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HsJSVal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
ext_name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
cstub_args
      cstub_body =
        [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
          [ SDoc
forall doc. IsLine doc => doc
lbrace,
            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Capability *cap = rts_lock();",
            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HaskellObj ret;",
            -- rts_evalLazyIO is fine, the top handler always returns
            -- an evaluated result
            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rts_evalLazyIO"
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
                ( [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
                    ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate
                      SDoc
forall doc. IsLine doc => doc
comma
                      [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"&cap",
                        (SDoc -> (Int, Scaled Type) -> SDoc)
-> SDoc -> [(Int, Scaled Type)] -> SDoc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                          ( \SDoc
acc (Int
i, Scaled Type
arg_ty) ->
                              [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rts_apply"
                                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
                                  ( [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
                                      ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate
                                        SDoc
forall doc. IsLine doc => doc
comma
                                        [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"cap",
                                          SDoc
acc,
                                          [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char]
"rts_mk" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
ffiType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty))
                                            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens
                                              ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [[Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"cap", Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i])
                                        ]
                                  )
                          )
                          (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'&' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
work_closure)
                          ([(Int, Scaled Type)] -> SDoc) -> [(Int, Scaled Type)] -> SDoc
forall a b. (a -> b) -> a -> b
$ [Int] -> [Scaled Type] -> [(Int, Scaled Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Scaled Type]
arg_tys,
                        [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"&ret"
                      ]
                )
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rts_checkSchedStatus"
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
ext_name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"cap")
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi,
            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"rts_unlock(cap);",
            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"return rts_getJSVal(ret);",
            SDoc
forall doc. IsLine doc => doc
rbrace
          ]
      cstub =
        SDoc
commonCDecls
          SDoc -> SDoc -> SDoc
$+$ SDoc
work_closure_decl
          SDoc -> SDoc -> SDoc
$+$ SDoc
cstub_attr
          SDoc -> SDoc -> SDoc
$+$ SDoc
cstub_proto
          SDoc -> SDoc -> SDoc
$+$ SDoc
cstub_body
  pure
    ( CHeader commonCDecls,
      CStub cstub [] [],
      "",
      -1,
      [work_id],
      [(work_id, work_rhs)]
    )

lookupGhcInternalVarId :: FastString -> String -> DsM Id
lookupGhcInternalVarId :: FastString -> [Char] -> DsM Id
lookupGhcInternalVarId FastString
m [Char]
v = do
  n <- Module -> OccName -> TcRnIf DsGblEnv DsLclEnv Name
forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig (FastString -> Module
mkGhcInternalModule FastString
m) ([Char] -> OccName
mkVarOcc [Char]
v)
  dsLookupGlobalId n

lookupGhcInternalTyCon :: FastString -> String -> DsM TyCon
lookupGhcInternalTyCon :: FastString -> [Char] -> DsM TyCon
lookupGhcInternalTyCon FastString
m [Char]
t = do
  n <- Module -> OccName -> TcRnIf DsGblEnv DsLclEnv Name
forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig (FastString -> Module
mkGhcInternalModule FastString
m) ([Char] -> OccName
mkTcOcc [Char]
t)
  dsLookupTyCon n

ffiType :: Type -> String
ffiType :: Type -> [Char]
ffiType = OccName -> [Char]
occNameString (OccName -> [Char]) -> (Type -> OccName) -> Type -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName (TyCon -> OccName) -> (Type -> TyCon) -> Type -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyCon, [Type]) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, [Type]) -> TyCon)
-> (Type -> (TyCon, [Type])) -> Type -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (TyCon, [Type])
splitTyConApp

commonCDecls :: SDoc
commonCDecls :: SDoc
commonCDecls =
  [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
    [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"typedef __externref_t HsJSVal;",
      [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HsJSVal rts_getJSVal(HaskellObj);",
      [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"HaskellObj rts_mkJSVal(Capability*, HsJSVal);"
    ]