    {-# 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);"
        ]