diff --git a/docs/users_guide/exts/ffi.rst b/docs/users_guide/exts/ffi.rst index 618a4dce524c52e62c9ba8c24c83d876356f156f..b2c8aca08f17c257ae1bd5311645da9cbe7930ff 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 79f26178527a9de5ff071da48ce461bd331dcfcc..514ec30f5405508027bda8a56989370deafe3984 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 d4ce9acb9432ece755b1ce6d1966299a54c7d525..787d503eaf1a6c24da61c50fdf186bdc5d91a6ac 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 7c25599f83bc7842f1fb6d8a7ae67abe7e9f5a52..4f1762a74a797a7d59f08112e19fb13050efd5de 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); /* -------------------------------------------------------------------------- */