Imports.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}

module GHC.Internal.Wasm.Prim.Imports (
  raiseJSException,
  stg_blockPromise,
  stg_messagePromiseUnit,
  stg_messagePromiseJSVal,
  stg_messagePromiseChar,
  stg_messagePromiseInt,
  stg_messagePromiseInt8,
  stg_messagePromiseInt16,
  stg_messagePromiseInt32,
  stg_messagePromiseInt64,
  stg_messagePromiseWord,
  stg_messagePromiseWord8,
  stg_messagePromiseWord16,
  stg_messagePromiseWord32,
  stg_messagePromiseWord64,
  stg_messagePromisePtr,
  stg_messagePromiseFunPtr,
  stg_messagePromiseFloat,
  stg_messagePromiseDouble,
  stg_messagePromiseStablePtr,
  stg_messagePromiseBool
) where

import GHC.Internal.Base
import GHC.Internal.Exception
import GHC.Internal.Exts
import GHC.Internal.IO.Unsafe
import GHC.Internal.Stable
import GHC.Internal.Wasm.Prim.Types

{-# OPAQUE raiseJSException #-}
raiseJSException :: JSVal -> a
raiseJSException v = throw $ JSException v

{-

Note [stg_blockPromise]
~~~~~~~~~~~~~~~~~~~~~~~

When desugaring a JSFFI async import, we first emit a sync import: it
returns a JSVal that represents a Promise. Now we need to wrap it in a
thunk with the same return type as the user written import, so that
when the thunk is forced, the thread will be suspended and only
resumed later when the Promise fulfills. This is done by
stg_blockPromise.

stg_blockPromise takes two arguments: the Promise, and a "message
promise" function which is a JSFFI sync import that sends a message to
the Promise via invoking promise.then(). When the Promise resolves
with a result, the callback passed in .then() invokes RTS API which
needs to box the JavaScript result with the correct rts_mk* function,
so for each possible return type, we need to define a distinct
"message promise" function. This is an implementation detail, not end
user's concern, the desugar logic picks the right one to be passed to
stg_blockPromise.

Once the thunk is forced, we first check if we're inside a C FFI
export's main thread and if so, throw WouldBlockException. Then we pin
the current TSO via a stable pointer and call the "message promise"
function. At this point, the Promise fulfill logic that resumes the
thread in the future has been set up, we can drop the Promise eagerly,
then arrange the current thread to block.

Blocking is done by readMVar. stg_blockPromise allocates an empty MVar
and pins it under a stable pointer, then finally blocks by readMVar.
The stable pointer is captured in the promise.then callback. When the
Promise is settled in the future, the promise.then callback writes the
result (or exception) to the MVar and then resumes Haskell execution.

-}

stg_blockPromise :: String -> JSVal -> (JSVal -> StablePtr Any -> IO ()) -> r
stg_blockPromise err_msg p msg_p = unsafeDupablePerformIO $ IO $ \s0 ->
  case stg_jsffi_check (unsafeCoerce# $ toException $ WouldBlockException err_msg) s0 of
    (# s1 #) -> case newMVar# s1 of
      (# s2, mv# #) -> case makeStablePtr# mv# s2 of
        (# s3, sp #) ->
          case unIO (msg_p p $ StablePtr $ unsafeCoerce# sp) s3 of
            -- Since we eagerly free the Promise here, we must return
            -- an updatable thunk in stg_blockPromise that can't be
            -- evaluated more than once, regardless of optimization
            -- level, otherwise runtime panic may happen. This
            -- property holds because:
            -- 1. We're using the single threaded RTS
            -- 2. Once the thunk is evaluated the first time and that
            --    thread is paused, lazy blackholing does happen
            -- 3. unsafeDupablePerformIO applies lazy to the result
            --    and prevents dmdanal from being naughty
            (# s4, _ #) -> case unIO (freeJSVal p) s4 of
              (# s5, _ #) ->
                readMVar# mv# s5

foreign import prim "stg_jsffi_check"
  stg_jsffi_check :: Any -> State# RealWorld -> (# State# RealWorld #)

foreign import javascript unsafe "$1.then(() => __exports.rts_promiseResolveUnit($2), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseUnit :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveJSVal($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseJSVal :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveChar($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseChar :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveInt($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseInt :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveInt8($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseInt8 :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveInt16($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseInt16 :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveInt32($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseInt32 :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveInt64($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseInt64 :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveWord($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseWord :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveWord8($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseWord8 :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveWord16($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseWord16 :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveWord32($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseWord32 :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveWord64($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseWord64 :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolvePtr($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromisePtr :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveFunPtr($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseFunPtr :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveFloat($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseFloat :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveDouble($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseDouble :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveStablePtr($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseStablePtr :: JSVal -> StablePtr Any -> IO ()

foreign import javascript unsafe "$1.then(res => __exports.rts_promiseResolveBool($2, res), err => __exports.rts_promiseReject($2, err))"
  stg_messagePromiseBool :: JSVal -> StablePtr Any -> IO ()