From f75e823e0a9ac9fbe661fce232324c5b103ee8a8 Mon Sep 17 00:00:00 2001
From: Cheng Shao <terrorjack@type.dance>
Date: Sat, 15 Mar 2025 00:32:12 +0000
Subject: [PATCH] rts: add hs_try_putmvar_with_value to RTS API
This commit adds hs_try_putmvar_with_value to rts. It allows more
flexibility than hs_try_putmvar by taking an additional value argument
as a closure to be put into the MVar. This function is used & tested
by the wasm backend runtime, though it makes sense to expose it as a
public facing RTS API function as well.
---
docs/users_guide/exts/ffi.rst | 11 +++++++++++
rts/RtsAPI.c | 15 +++++++++++++--
rts/RtsSymbols.c | 1 +
rts/include/HsFFI.h | 2 ++
4 files changed, 27 insertions(+), 2 deletions(-)
diff --git a/docs/users_guide/exts/ffi.rst b/docs/users_guide/exts/ffi.rst
index 618a4dce524..b2c8aca08f1 100644
--- a/docs/users_guide/exts/ffi.rst
+++ b/docs/users_guide/exts/ffi.rst
@@ -976,6 +976,8 @@ wake up a Haskell thread from C/C++.
void hs_try_putmvar (int capability, HsStablePtr sp);
+ void hs_try_putmvar_with_value (int capability, HsStablePtr sp, StgClosure *value);
+
The C call ``hs_try_putmvar(cap, mvar)`` is equivalent to the Haskell
call ``tryPutMVar mvar ()``, except that it is
@@ -988,6 +990,15 @@ call ``tryPutMVar mvar ()``, except that it is
the ``MVar`` is empty; if it is full, ``hs_try_putmvar()`` will have
no effect.
+The C call ``hs_try_putmvar_with_value(cap, mvar, value)`` takes an
+additional ``value`` argument, which is an RTS closure pointer of the
+value to be put into the MVar. It works the same way as
+``hs_try_putmvar`` while offering a bit more flexibility: for a C
+value to be passed to Haskell, you can directly call one of the
+``rts_mk`` functions to wrap the C value and put it into the MVar,
+instead of writing it to a heap location and peeking it from a pointer
+in Haskell.
+
**Example**. Suppose we have a C/C++ function to call that will return and then
invoke a callback at some point in the future, passing us some data.
We want to wait in Haskell for the callback to be called, and retrieve
diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index 79f26178527..514ec30f540 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -942,12 +942,23 @@ void rts_done (void)
it would be very difficult for the caller to arrange to free the StablePtr
in all circumstances.
+ There's also hs_try_putmvar_with_value(cap, mvar, value) which
+ allows putting a custom value other than () in the MVar, typically
+ a closure created by one of rts_mk*() functions.
+
For more details, see the section "Waking up Haskell threads from C" in the
User's Guide.
-------------------------------------------------------------------------- */
void hs_try_putmvar (/* in */ int capability,
/* in */ HsStablePtr mvar)
+{
+ hs_try_putmvar_with_value(capability, mvar, TAG_CLOSURE(1, Unit_closure));
+}
+
+void hs_try_putmvar_with_value (/* in */ int capability,
+ /* in */ HsStablePtr mvar,
+ /* in */ StgClosure *value)
{
Task *task = getMyTask();
Capability *cap;
@@ -963,7 +974,7 @@ void hs_try_putmvar (/* in */ int capability,
#if !defined(THREADED_RTS)
- performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), Unit_closure);
+ performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), value);
freeStablePtr(mvar);
#else
@@ -976,7 +987,7 @@ void hs_try_putmvar (/* in */ int capability,
task->cap = cap;
RELEASE_LOCK(&cap->lock);
- performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), Unit_closure);
+ performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), value);
freeStablePtr(mvar);
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index d678a1f761f..5edb936f2eb 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -597,6 +597,7 @@ extern char **environ;
SymI_HasProto(hs_hpc_module) \
SymI_HasProto(hs_thread_done) \
SymI_HasProto(hs_try_putmvar) \
+ SymI_HasProto(hs_try_putmvar_with_value) \
SymI_HasProto(defaultRtsConfig) \
SymI_HasProto(initLinker) \
SymI_HasProto(initLinker_) \
diff --git a/rts/include/HsFFI.h b/rts/include/HsFFI.h
index 7c25599f83b..4f1762a74a7 100644
--- a/rts/include/HsFFI.h
+++ b/rts/include/HsFFI.h
@@ -21,6 +21,7 @@ extern "C" {
/* get types from GHC's runtime system */
#include "ghcconfig.h"
+#include "rts/Types.h"
#include "stg/Types.h"
/* get limits for floating point types */
@@ -138,6 +139,7 @@ extern int hs_spt_keys(StgPtr keys[], int szKeys);
extern int hs_spt_key_count (void);
extern void hs_try_putmvar (int capability, HsStablePtr sp);
+extern void hs_try_putmvar_with_value (int capability, HsStablePtr sp, StgClosure *value);
/* -------------------------------------------------------------------------- */
--
GitLab