{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-} module GHC.Internal.Wasm.Prim.Imports ( 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 calling stg_jsffi_block: it pushes a stg_jsffi_block frame and suspends the thread. The payload of stg_jsffi_block frame is a single pointer field that holds the return value. When the Promise is resolved with the result, the RTS fetches the TSO indexed by the stable pointer passed earlier, checks for the top stack frame to see if it's still a stg_jsffi_block frame (could be stripped by an async exception), fills in the boxed result and restarts execution. In case of a Promise rejection, the closure being filled is generated via raiseJSException. -} stg_blockPromise :: JSVal -> (JSVal -> StablePtr Any -> IO ()) -> r stg_blockPromise p msg_p = unsafeDupablePerformIO $ IO $ \s0 -> case stg_jsffi_check (unsafeCoerce# $ toException WouldBlockException) s0 of (# s1 #) -> case myThreadId# s1 of (# s2, tso #) -> case makeStablePtr# tso 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, _ #) -> -- raiseJSException_closure is used by the RTS in case -- the Promise is rejected, and it is likely a CAF. So -- we need to keep it alive when we block waiting for -- the Promise to resolve or reject, and also mark it -- as OPAQUE just to be sure. keepAlive# raiseJSException s5 $ stg_jsffi_block $ throw PromisePendingException foreign import prim "stg_jsffi_check" stg_jsffi_check :: Any -> State# RealWorld -> (# State# RealWorld #) foreign import prim "stg_jsffi_block" stg_jsffi_block :: Any -> State# RealWorld -> (# State# RealWorld, r #) 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 ()