{-# 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 ()