source: https://phabricator.haskell.org/D2501
Authored by simonmar on Wed, Aug 31, 9:59 AM.
The GHC runtime treats program exit as a special case, to avoid the need
to wait for blocked threads when a standalone executable exits. Since
the program and all its threads are about to terminate at the same time
that the code is removed from memory, it isn't necessary to ensure that
the threads have exited first. (Unofficially, if you want to use this
fast and loose version of ``hs_exit()``, then call
``shutdownHaskellAndExit()`` instead).
.. _hs_try_putmvar:
Waking up Haskell threads from C
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Sometimes we want to be able to wake up a Haskell thread from some C
code. For example, when using a callback-based C API, we register a C
callback and then we need to wait for the callback to run.
One way to do this is to create a ``foreign export`` that will do
whatever needs to be done to wake up the Haskell thread - perhaps
``putMVar`` - and then call this from our C callback. There are a
couple of problems with this:
1. Calling a foreign export has a lot of overhead: it creates a
complete new Haskell thread, for example.
2. The call may block for a long time if a GC is in progress. We
can't use this method if the C API we're calling doesn't allow
blocking in the callback.
For these reasons GHC provides an external API to ``tryPutMVar``,
``hs_try_putmvar``, which you can use to cheaply and asynchronously
wake up a Haskell thread from C/C++.
.. code-block:: c
void hs_try_putmvar (int capability, HsStablePtr sp);
The C call ``hs_try_putmvar(cap, mvar)`` is equivalent to the Haskell
call ``tryPutMVar mvar ()``, except that it is
* non-blocking: takes a bounded, short, amount of time
* asynchronous: the actual putMVar may be performed after the call
returns (for example, if the RTS is currently garbage collecting).
That's why ``hs_try_putmvar()`` doesn't return a result to say
whether the put succeeded. It is your responsibility to ensure that
the ``MVar`` is empty; if it is full, ``hs_try_putmvar()`` will have
no effect.
**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
the data. We can do it like this:
.. code-block:: haskell
import GHC.Conc (newStablePtrPrimMVar, PrimMVar)
makeExternalCall = mask_ $ do
mvar <- newEmptyMVar
sp <- newStablePtrPrimMVar mvar
fp <- mallocForeignPtr
withForeignPtr fp $ \presult -> do
cap <- threadCapability =<< myThreadId
scheduleCallback sp cap presult
takeMVar mvar `onException`
forkIO (do takeMVar mvar; touchForeignPtr fp)
peek presult
foreign import ccall "scheduleCallback"
scheduleCallback :: StablePtr PrimMVar
-> Int
-> Ptr Result
-> IO ()
And inside ``scheduleCallback``, we create a callback that will in due
course store the result data in the ``Ptr Result``, and then call
``hs_try_putmvar()``.
There are a few things to note here.
* There's a special function to create the ``StablePtr``:
``newStablePtrPrimMVar``, because the RTS needs a ``StablePtr`` to
the primitive ``MVar#`` object, and we can't create that directly.
Do *not* just use ``newStablePtr`` on the ``MVar``: your program
will crash.
* The ``StablePtr`` is freed by ``hs_try_putmvar()``. This is because
it would otherwise be difficult to arrange to free the ``StablePtr``
reliably: we can't free it in Haskell, because if the ``takeMVar``
is interrupted by an asynchronous exception, then the callback will
fire at a later time. We can't free it in C, because we don't know
when to free it (not when ``hs_try_putmvar()`` returns, because that
is an async call that uses the ``StablePtr`` at some time in the
future).
* The ``mask_`` is to avoid asynchronous exceptions before the
``scheduleCallback`` call, which would leak the ``StablePtr``.
* We find out the current capability number and pass it to C. This is
passed back to ``hs_try_putmvar``, and helps the RTS to know which
capability it should try to perform the ``tryPutMVar`` on. If you
don't care, you can pass ``-1`` for the capability to
``hs_try_putmvar``, and it will pick an arbitrary one.
Picking the right capability will help avoid unnecessary context
switches. Ideally you should pass the capability that the thread
that will be woken up last ran on, which you can find by calling
``threadCapability`` in Haskell.
* If you want to also pass some data back from the C callback to
Haskell, this is best done by first allocating some memory in
Haskell to receive the data, and passing the address to C, as we did
in the above example.
* ``takeMVar`` can be interrupted by an asynchronous exception. If
this happens, the callback in C will still run at some point in the
future, will still write the result, and will still call
``hs_try_putmvar()``. Therefore we have to arrange that the memory
for the result stays alive until the callback has run, so if an
exception is thrown during ``takeMVar`` we fork another thread to
wait for the callback and hold the memory alive using
``touchForeignPtr``.
For a fully working example, see
``testsuite/tests/concurrent/should_run/hs_try_putmvar001.hs`` in the
GHC source tree.
.. _ffi-floating-point:
Floating point and the FFI
~~~~~~~~~~~~~~~~~~~~~~~~~~
.. index::
single: Floating point; and the FFI
extern void hs_free_stable_ptr (HsStablePtr sp);
extern void hs_free_fun_ptr (HsFunPtr fp);
extern StgPtr hs_spt_lookup(StgWord64 key[2]);
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);
/* -------------------------------------------------------------------------- */
#ifdef __cplusplus
}
#endif
#endif /* HSFFI_H */
, yield
, labelThread
, mkWeakThreadId
, ThreadStatus(..), BlockReason(..)
, threadStatus
, threadCapability
, newStablePtrPrimMVar, PrimMVar
-- * Waiting
, threadDelay
, registerDelay
, threadWaitRead
, threadWaitWrite
, threadWaitReadSTM
, threadWaitWriteSTM
, closeFdWith
, yield
, labelThread
, mkWeakThreadId
, ThreadStatus(..), BlockReason(..)
, threadStatus
, threadCapability
, newStablePtrPrimMVar, PrimMVar
-- * Allocation counter and quota
, setAllocationCounter
, getAllocationCounter
, enableAllocationLimit
, disableAllocationLimit
-- * TVars
, STM(..)
import GHC.IO.Exception
import GHC.Exception
import qualified GHC.Foreign
import GHC.IORef
import GHC.MVar
import GHC.Ptr
import GHC.Real ( fromIntegral )
import GHC.Show ( Show(..), showString )
import GHC.Stable ( StablePtr(..) )
import GHC.Weak
infixr 0 `par`, `pseq`
-----------------------------------------------------------------------------
-- 'ThreadId', 'par', and 'fork'
-----------------------------------------------------------------------------
--
-- @since 4.6.0.0
mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
case mkWeakNoFinalizer# t# t s of
(# s1, w #) -> (# s1, Weak w #)
data PrimMVar
-- | Make a StablePtr that can be passed to the C function
-- @hs_try_putmvar()@. The RTS wants a 'StablePtr' to the underlying
-- 'MVar#', but a 'StablePtr#' can only refer to lifted types, so we
-- have to cheat by coercing.
newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar)
newStablePtrPrimMVar (MVar m) = IO $ \s0 ->
case makeStablePtr# (unsafeCoerce# m :: PrimMVar) s0 of
(# s1, sp #) -> (# s1, StablePtr sp #)
-----------------------------------------------------------------------------
-- Transactional heap operations
-----------------------------------------------------------------------------
-- TVars are shared memory locations which support atomic memory
-- transactions.
-- |A monad supporting atomic memory transactions.
Task *spare_workers;
uint32_t n_spare_workers; // count of above
// This lock protects:
// running_task
// returning_tasks_{hd,tl}
// wakeup_queue
// inbox
// putMVars
Mutex lock;
// Tasks waiting to return from a foreign call, or waiting to make
// a new call-in using this Capability (NULL if empty).
// NB. this field needs to be modified by tasks other than the
// running_task, so it requires cap->lock to modify. A task can
// check whether it is NULL without taking the lock, however.
Task *returning_tasks_hd; // Singly-linked, with head/tail
Task *returning_tasks_tl;
uint32_t n_returning_tasks;
// Messages, or END_TSO_QUEUE.
// Locks required: cap->lock
Message *inbox;
// putMVars are really messages, but they're allocated with malloc() so they
// can't go on the inbox queue: the GC would get confused.
struct PutMVar_ *putMVars;
SparkPool *sparks;
// Stats on spark creation/conversion
SparkCounters spark_stats;
#if !defined(mingw32_HOST_OS)
// IO manager for this cap
int io_manager_control_wr_fd;
#endif
extern uint32_t numa_map[MAX_NUMA_NODES];
#define capNoToNumaNode(n) ((n) % n_numa_nodes)
/* -----------------------------------------------------------------------------
Messages
-------------------------------------------------------------------------- */
typedef struct PutMVar_ {
StgStablePtr mvar;
struct PutMVar_ *link;
} PutMVar;
#ifdef THREADED_RTS
INLINE_HEADER rtsBool emptyInbox(Capability *cap);
#endif // THREADED_RTS
/* -----------------------------------------------------------------------------
* INLINE functions... private below here
stopCapability(cap);
cap->context_switch = 1;
}
#ifdef THREADED_RTS
INLINE_HEADER rtsBool emptyInbox(Capability *cap)
{
return (cap->inbox == (Message*)END_TSO_QUEUE &&
cap->putMVars == NULL);
}
#endif
#include "EndPrivate.h"
#endif /* CAPABILITY_H */
cap->spare_workers = NULL;
cap->n_spare_workers = 0;
cap->suspended_ccalls = NULL;
cap->n_suspended_ccalls = 0;
cap->returning_tasks_hd = NULL;
cap->returning_tasks_tl = NULL;
cap->n_returning_tasks = 0;
cap->inbox = (Message*)END_TSO_QUEUE;
cap->putMVars = NULL;
cap->sparks = allocSparkPool();
cap->spark_stats.created = 0;
cap->spark_stats.dud = 0;
cap->spark_stats.overflowed = 0;
cap->spark_stats.converted = 0;
cap->spark_stats.gcd = 0;
cap->spark_stats.fizzled = 0;
#if !defined(mingw32_HOST_OS)
#define PRELUDE_INFO(i) extern const StgInfoTable DLL_IMPORT_DATA_VARNAME(i)
#define PRELUDE_CLOSURE(i) extern StgClosure DLL_IMPORT_DATA_VARNAME(i)
#endif
/* Define canonical names so we can abstract away from the actual
* modules these names are defined in.
*/
PRELUDE_CLOSURE(ghczmprim_GHCziTuple_Z0T_closure);
PRELUDE_CLOSURE(ghczmprim_GHCziTypes_True_closure);
PRELUDE_CLOSURE(ghczmprim_GHCziTypes_False_closure);
PRELUDE_CLOSURE(base_GHCziPack_unpackCString_closure);
PRELUDE_CLOSURE(base_GHCziWeak_runFinalizzerBatch_closure);
#ifdef IN_STG_CODE
extern W_ ZCMain_main_closure[];
#else
PRELUDE_INFO(base_GHCziInt_I64zh_con_info);
PRELUDE_INFO(base_GHCziWord_W8zh_con_info);
PRELUDE_INFO(base_GHCziWord_W16zh_con_info);
PRELUDE_INFO(base_GHCziWord_W32zh_con_info);
PRELUDE_INFO(base_GHCziWord_W64zh_con_info);
PRELUDE_INFO(base_GHCziStable_StablePtr_static_info);
PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
#define Unit_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziTuple_Z0T_closure)
#define True_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_True_closure)
#define False_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_False_closure)
#define unpackCString_closure DLL_IMPORT_DATA_REF(base_GHCziPack_unpackCString_closure)
#define runFinalizerBatch_closure DLL_IMPORT_DATA_REF(base_GHCziWeak_runFinalizzerBatch_closure)
#define mainIO_closure (&ZCMain_main_closure)
#define runSparks_closure DLL_IMPORT_DATA_REF(base_GHCziConcziSync_runSparks_closure)
#define ensureIOManagerIsRunning_closure DLL_IMPORT_DATA_REF(base_GHCziConcziIO_ensureIOManagerIsRunning_closure)
ASSERT(why_blocked == BlockedOnMVar);
unlockClosure(mvar, info);
return ();
}
// NOTE: there is another implementation of this function in
// Threads.c:performTryPutMVar(). Keep them in sync! It was
// measurably slower to call the C function from here (70% for a
// tight loop doing tryPutMVar#).
//
// TODO: we could kill the duplication by making tryPutMVar# into an
// inline primop that expands into a C call to performTryPutMVar().
stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */
P_ val, /* :: a */ )
{
W_ info, tso, q;
LOCK_CLOSURE(mvar, info);
if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
}
ASSERT(why_blocked == BlockedOnMVar);
unlockClosure(mvar, info);
return (1);
}
stg_readMVarzh ( P_ mvar, /* :: MVar a */ )
{
W_ val, info, tso, q;
LOCK_CLOSURE(mvar, info);
/* If the MVar is empty, put ourselves on the blocked readers
* list and wait until we're woken up.
#include "RtsAPI.h"
#include "HsFFI.h"
#include "RtsUtils.h"
#include "Prelude.h"
#include "Schedule.h"
#include "Capability.h"
#include "Stable.h"
#include "Threads.h"
#include "Weak.h"
/* ----------------------------------------------------------------------------
Building Haskell objects from C datatypes.
TODO: Currently this code does not tag created pointers,
however it is not unsafe (the constructor code will do it)
just inefficient.
}
}
void rts_done (void)
{
freeMyTask();
}
/* -----------------------------------------------------------------------------
tryPutMVar from outside Haskell
The C call
hs_try_putmvar(cap, mvar)
is equivalent to the Haskell call
tryPutMVar mvar ()
but it is
* non-blocking: takes a bounded, short, amount of time
* asynchronous: the actual putMVar may be performed after the
call returns. That's why hs_try_putmvar() doesn't return a
result to say whether the put succeeded.
NOTE: this call transfers ownership of the StablePtr to the RTS, which will
free it after the tryPutMVar has taken place. The reason is that otherwise,
it would be very difficult for the caller to arrange to free the StablePtr
in all circumstances.
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)
{
Task *task = getTask();
Capability *cap;
if (capability < 0) {
capability = task->preferred_capability;
if (capability < 0) {
capability = 0;
}
}
cap = capabilities[capability % enabled_capabilities];
#if !defined(THREADED_RTS)
performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), Unit_closure);
freeStablePtr(mvar);
#else
ACQUIRE_LOCK(&cap->lock);
// If the capability is free, we can perform the tryPutMVar immediately
if (cap->running_task == NULL) {
cap->running_task = task;
task->cap = cap;
RELEASE_LOCK(&cap->lock);
performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), Unit_closure);
freeStablePtr(mvar);
// Wake up the capability, which will start running the thread that we
// just awoke (if there was one).
releaseCapability(cap);
} else {
PutMVar *p = stgMallocBytes(sizeof(PutMVar),"hs_try_putmvar");
// We cannot deref the StablePtr if we don't have a capability,
// so we have to store it and deref it later.
p->mvar = mvar;
p->link = cap->putMVars;
cap->putMVars = p;
RELEASE_LOCK(&cap->lock);
}
#endif
}
// capabilities on the same NUMA node preferably, but not exclusively.
for (i = (cap->no + 1) % n_capabilities, n_free_caps=0;
n_free_caps < n_wanted_caps && i != cap->no;
i = (i + 1) % n_capabilities) {
cap0 = capabilities[i];
if (cap != cap0 && !cap0->disabled && tryGrabCapability(cap0,task)) {
if (!emptyRunQueue(cap0)
|| cap0->n_returning_tasks != 0
|| !emptyInbox(cap0)) {
// it already has some work, we just grabbed it at
// the wrong moment. Or maybe it's deadlocked!
releaseCapability(cap0);
} else {
free_caps[n_free_caps++] = cap0;
}
}
}
* Process message in the current Capability's inbox
* ------------------------------------------------------------------------- */
static void
scheduleProcessInbox (Capability **pcap USED_IF_THREADS)
{
#if defined(THREADED_RTS)
Message *m, *next;
PutMVar *p, *pnext;
int r;
Capability *cap = *pcap;
while (!emptyInbox(cap)) {
if (cap->r.rCurrentNursery->link == NULL ||
g0->n_new_large_words >= large_alloc_lim) {
scheduleDoGC(pcap, cap->running_task, rtsFalse);
cap = *pcap;
}
// don't use a blocking acquire; if the lock is held by
// another thread then just carry on. This seems to avoid
// getting stuck in a message ping-pong situation with other
// processors. We'll check the inbox again later anyway.
//
// We should really use a more efficient queue data structure
// here. The trickiness is that we must ensure a Capability
// never goes idle if the inbox is non-empty, which is why we
// use cap->lock (cap->lock is released as the last thing
// before going idle; see Capability.c:releaseCapability()).
r = TRY_ACQUIRE_LOCK(&cap->lock);
if (r != 0) return;
m = cap->inbox;
p = cap->putMVars;
cap->inbox = (Message*)END_TSO_QUEUE;
cap->putMVars = NULL;
RELEASE_LOCK(&cap->lock);
while (m != (Message*)END_TSO_QUEUE) {
next = m->link;
executeMessage(cap, m);
m = next;
}
while (p != NULL) {
pnext = p->link;
performTryPutMVar(cap, (StgMVar*)deRefStablePtr(p->mvar),
Unit_closure);
freeStablePtr(p->mvar);
stgFree(p);
p = pnext;
}
}
#endif
}
/* ----------------------------------------------------------------------------
* Activate spark threads (THREADED_RTS)
* ------------------------------------------------------------------------- */
#if defined(THREADED_RTS)
static void
scheduleActivateSpark(Capability *cap)
{
// The current top-of-stack InCall
struct InCall_ *incall;
uint32_t n_spare_incalls;
struct InCall_ *spare_incalls;
rtsBool worker; // == rtsTrue if this is a worker Task
rtsBool stopped; // == rtsTrue between newBoundTask and
// boundTaskExiting, or in a worker Task.
// So that we can detect when a finalizer illegally calls back into Haskell
rtsBool running_finalizers;
// if >= 0, this Capability will be used for in-calls
int preferred_capability;
// Links tasks on the returning_tasks queue of a Capability, and
void initTaskManager (void);
uint32_t freeTaskManager (void);
// Create a new Task for a bound thread. This Task must be released
// by calling boundTaskExiting. The Task is cached in
// thread-local storage and will remain even after boundTaskExiting()
// has been called; to free the memory, see freeMyTask().
//
Task* newBoundTask (void);
// Return the current OS thread's Task, which is created if it doesn't already
// exist. After you have finished using RTS APIs, you should call freeMyTask()
// to release this thread's Task.
Task* getTask (void);
// The current task is a bound task that is exiting.
//
void boundTaskExiting (Task *task);
// Free a Task if one was previously allocated by newBoundTask().
// This is not necessary unless the thread that called newBoundTask()
// will be exiting, or if this thread has finished calling Haskell
// functions.
uint32_t taskCount;
uint32_t workerCount;
uint32_t currentWorkerCount;
uint32_t peakWorkerCount;
static int tasksInitialized = 0;
static void freeTask (Task *task);
static Task * newTask (rtsBool);
#if defined(THREADED_RTS)
Mutex all_tasks_mutex;
#endif
/* -----------------------------------------------------------------------------
* Remembering the current thread's Task
#endif
#endif
tasksInitialized = 0;
return tasksRunning;
}
Task* getTask (void)
{
Task *task;
task = myTask();
if (task != NULL) {
return task;
} else {
task = newTask(rtsFalse);
for (incall = task->spare_incalls; incall != NULL; incall = next) {
next = incall->next;
stgFree(incall);
}
stgFree(task);
}
static Task*
newTask (rtsBool worker)
{
Task *task;
#define ROUND_TO_CACHE_LINE(x) ((((x)+63) / 64) * 64)
task = stgMallocBytes(ROUND_TO_CACHE_LINE(sizeof(Task)), "newTask");
task->cap = NULL;
task->worker = worker;
task->stopped = rtsTrue;
task->running_finalizers = rtsFalse;
task->n_spare_incalls = 0;
task->spare_incalls = NULL;
task->incall = NULL;
task->preferred_capability = -1;
#if defined(THREADED_RTS)
initCondition(&task->cond);
{
Task *task;
if (!tasksInitialized) {
errorBelch("newBoundTask: RTS is not initialised; call hs_init() first");
stg_exit(EXIT_FAILURE);
}
task = getTask();
task->stopped = rtsFalse;
newInCall(task);
debugTrace(DEBUG_sched, "new task (taskCount: %d)", taskCount);
return task;
}
startWorkerTask (Capability *cap)
{
int r;
OSThreadId tid;
Task *task;
// A worker always gets a fresh Task structure.
task = newTask(rtsTrue);
task->stopped = rtsFalse;
// The lock here is to synchronise with taskStart(), to make sure
// that we have finished setting up the Task structure before the
// worker thread reads it.
ACQUIRE_LOCK(&task->lock);
// We don't emit a task creation event here, but in workerStart,
// where the kernel thread id is known.
}
#endif /* THREADED_RTS */
void rts_setInCallCapability (
int preferred_capability,
int affinity USED_IF_THREADS)
{
Task *task = getTask();
task->preferred_capability = preferred_capability;
#ifdef THREADED_RTS
if (affinity) {
if (RtsFlags.ParFlags.setAffinity) {
setThreadAffinity(preferred_capability, n_capabilities);
}
if (RtsFlags.GcFlags.numa) {
rtsBool removeThreadFromDeQueue (Capability *cap, StgTSO **head, StgTSO **tail, StgTSO *tso);
StgBool isThreadBound (StgTSO* tso);
// Overfow/underflow
void threadStackOverflow (Capability *cap, StgTSO *tso);
W_ threadStackUnderflow (Capability *cap, StgTSO *tso);
rtsBool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value);
#ifdef DEBUG
void printThreadBlockage (StgTSO *tso);
void printThreadStatus (StgTSO *t);
void printAllThreads (void);
void printThreadQueue (StgTSO *t);
#endif
#include "EndPrivate.h"
#endif /* THREADS_H */
// we're about to run it, better mark it dirty
dirty_STACK(cap, new_stack);
return retvals;
}
/* ----------------------------------------------------------------------------
Implementation of tryPutMVar#
NOTE: this should be kept in sync with stg_tryPutMVarzh in PrimOps.cmm
------------------------------------------------------------------------- */
rtsBool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value)
{
const StgInfoTable *info;
StgMVarTSOQueue *q;
StgTSO *tso;
info = lockClosure((StgClosure*)mvar);
if (mvar->value != &stg_END_TSO_QUEUE_closure) {
#if defined(THREADED_RTS)
unlockClosure((StgClosure*)mvar, info);
#endif
return rtsFalse;
}
q = mvar->head;
loop:
if (q == (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure) {
/* No further takes, the MVar is now full. */
if (info == &stg_MVAR_CLEAN_info) {
dirty_MVAR(&cap->r, (StgClosure*)mvar);
}
mvar->value = value;
unlockClosure((StgClosure*)mvar, &stg_MVAR_DIRTY_info);
return rtsTrue;
}
if (q->header.info == &stg_IND_info ||
q->header.info == &stg_MSG_NULL_info) {
q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee;
goto loop;
}
// There are takeMVar(s) waiting: wake up the first one
tso = q->tso;
mvar->head = q->link;
if (mvar->head == (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure) {
mvar->tail = (StgMVarTSOQueue*)&stg_END_TSO_QUEUE_closure;
}
ASSERT(tso->block_info.closure == (StgClosure*)mvar);
// save why_blocked here, because waking up the thread destroys
// this information
StgWord why_blocked = tso->why_blocked;
// actually perform the takeMVar
StgStack* stack = tso->stackobj;
stack->sp[1] = (W_)value;
stack->sp[0] = (W_)&stg_ret_p_info;
// indicate that the MVar operation has now completed.
tso->_link = (StgTSO*)&stg_END_TSO_QUEUE_closure;
if (stack->dirty == 0) {
dirty_STACK(cap, stack);
}
tryWakeupThread(cap, tso);
// If it was an readMVar, then we can still do work,
// so loop back. (XXX: This could take a while)
if (why_blocked == BlockedOnMVarRead) {
q = ((StgMVarTSOQueue*)q)->link;
goto loop;
}
ASSERT(why_blocked == BlockedOnMVar);
unlockClosure((StgClosure*)mvar, info);
return rtsTrue;
}
/* ----------------------------------------------------------------------------
* Debugging: why is a thread blocked
* ------------------------------------------------------------------------- */
#if DEBUG
void
printThreadBlockage(StgTSO *tso)
{
switch (tso->why_blocked) {
, "-Wl,-u,_base_GHCziStable_StablePtr_static_info"
, "-Wl,-u,_ghczmprim_GHCziTypes_Izh_con_info"
, "-Wl,-u,_ghczmprim_GHCziTypes_Czh_con_info"
, "-Wl,-u,_ghczmprim_GHCziTypes_Fzh_con_info"
, "-Wl,-u,_ghczmprim_GHCziTypes_Dzh_con_info"
, "-Wl,-u,_base_GHCziPtr_Ptr_con_info"
, "-Wl,-u,_base_GHCziPtr_FunPtr_con_info"
, "-Wl,-u,_base_GHCziStable_StablePtr_con_info"
, "-Wl,-u,_ghczmprim_GHCziTuple_Z0T_closure"
, "-Wl,-u,_ghczmprim_GHCziTypes_False_closure"
, "-Wl,-u,_ghczmprim_GHCziTypes_True_closure"
, "-Wl,-u,_base_GHCziPack_unpackCString_closure"
, "-Wl,-u,_base_GHCziIOziException_stackOverflow_closure"
, "-Wl,-u,_base_GHCziIOziException_heapOverflow_closure"
, "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure"
, "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure"
, "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure"
, "-Wl,-u,base_GHCziStable_StablePtr_static_info"
, "-Wl,-u,ghczmprim_GHCziTypes_Izh_con_info"
, "-Wl,-u,ghczmprim_GHCziTypes_Czh_con_info"
, "-Wl,-u,ghczmprim_GHCziTypes_Fzh_con_info"
, "-Wl,-u,ghczmprim_GHCziTypes_Dzh_con_info"
, "-Wl,-u,base_GHCziPtr_Ptr_con_info"
, "-Wl,-u,base_GHCziPtr_FunPtr_con_info"
, "-Wl,-u,base_GHCziStable_StablePtr_con_info"
, "-Wl,-u,ghczmprim_GHCziTuple_Z0T_closure"
, "-Wl,-u,ghczmprim_GHCziTypes_False_closure"
, "-Wl,-u,ghczmprim_GHCziTypes_True_closure"
, "-Wl,-u,base_GHCziPack_unpackCString_closure"
, "-Wl,-u,base_GHCziIOziException_stackOverflow_closure"
, "-Wl,-u,base_GHCziIOziException_heapOverflow_closure"
, "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure"
, "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure"
, "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnSTM_closure"
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
conc059_setup :
'$(TEST_HC)' $(TEST_HC_OPTS) -c conc059.hs
hs_try_putmvar002_setup :
'$(TEST_HC)' $(TEST_HC_OPTS) -c hs_try_putmvar002.hs
hs_try_putmvar003_setup :
'$(TEST_HC)' $(TEST_HC_OPTS) -c hs_try_putmvar003.hs
test('setnumcapabilities001',
[ only_ways(['threaded1','threaded2']),
extra_run_opts('4 12 2000'),
req_smp ],
compile_and_run, [''])
# omit ghci, which can't handle unboxed tuples:
test('compareAndSwap', [omit_ways(['ghci','hpc']), reqlib('primitive')], compile_and_run, [''])
test('hs_try_putmvar001',
[
when(opsys('mingw32'),skip), # uses pthread APIs in the C code
only_ways(['threaded1','threaded2']),
extra_clean(['hs_try_putmvar001_c.o'])],
compile_and_run,
['hs_try_putmvar001_c.c'])
# A benchmark for hs_try_putmvar() vs. foreign export
# This one should work for both threaded and non-threaded RTS
test('hs_try_putmvar002',
[
pre_cmd('$MAKE -s --no-print-directory hs_try_putmvar002_setup'),
extra_clean(['hs_try_putmvar002_c.o']),
extra_run_opts('1 8 10000')
],
compile_and_run,
['hs_try_putmvar002_c.c'])
# Another benchmark for hs_try_putmvar() vs. foreign export
test('hs_try_putmvar003',
[
when(opsys('mingw32'),skip), # uses pthread APIs in the C code
pre_cmd('$MAKE -s --no-print-directory hs_try_putmvar003_setup'),
only_ways(['threaded1','threaded2']),
extra_clean(['hs_try_putmvar003_c.o']),
extra_run_opts('1 16 32 100')
],
compile_and_run,
['hs_try_putmvar003_c.c'])
{-# LANGUAGE MagicHash #-}
module Main where
import Control.Concurrent
import Control.Exception
import Foreign
import Foreign.C
import GHC.Conc
import GHC.Prim
-- Sample code demonstrating proper use of hs_try_putmvar()
main = do
makeExternalCall >>= print
threadDelay 100000
makeExternalCall :: IO CInt
makeExternalCall = mask_ $ do
mvar <- newEmptyMVar
sp <- newStablePtrPrimMVar mvar -- freed by hs_try_takemvar()
fp <- mallocForeignPtr
withForeignPtr fp $ \presult -> do
(cap,_) <- threadCapability =<< myThreadId
scheduleCallback sp cap presult
takeMVar mvar `onException` forkIO (do takeMVar mvar; touchForeignPtr fp)
-- the C callback will still run if takeMVar is interrupted, so the
-- exception handler keeps the result memory alive long enough.
peek presult
foreign import ccall "scheduleCallback"
scheduleCallback :: StablePtr PrimMVar
-> Int
-> Ptr CInt
-> IO ()
42
#include "HsFFI.h"
#include "Rts.h"
#include "RtsAPI.h"
#include <unistd.h>
#include <pthread.h>
struct callback {
HsStablePtr mvar;
int cap;
int *presult;
};
void* callback(struct callback *p)
{
usleep(200);
*p->presult = 42;
hs_try_putmvar(p->cap,p->mvar);
free(p);
hs_thread_done();
return NULL;
}
void scheduleCallback(HsStablePtr mvar, HsInt cap, int *presult)
{
pthread_t t;
struct callback *p = malloc(sizeof(struct callback));
p->mvar = mvar;
p->cap = cap;
p->presult = presult;
pthread_create(&t, NULL, callback, p);
}
{-# LANGUAGE MagicHash #-}
module Main where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Foreign hiding (void)
import Foreign.C
import GHC.Conc
import GHC.Prim
import System.Environment
-- Measure raw throughput, for M threads that each do N calls to C
-- that call back to hs_try_putmvar() or the foreign export equivalent
main = do
args <- getArgs
case args of
["1",n,m] -> experiment2 (read m) (experiment1 (read n))
["2",n,m] -> experiment2 (read m) (experiment1FE (read n))
-- -----------------------------------------------------------------------------
experiment1 :: Int -> IO ()
experiment1 n = mask_ $ do
mvar <- newEmptyMVar
(cap,_) <- threadCapability =<< myThreadId
replicateM_ n $ do
sp <- newStablePtrPrimMVar mvar
externalPutMVar sp cap
takeMVar mvar
foreign import ccall "externalPutMVar"
externalPutMVar :: StablePtr PrimMVar
-> Int
-> IO ()
experiment1FE :: Int -> IO ()
experiment1FE n = do
mvar <- newEmptyMVar
(cap,_) <- threadCapability =<< myThreadId
bracket (newStablePtr mvar) freeStablePtr $ \sp -> do
replicateM_ n $ do externalPutMVarFE sp cap; takeMVar mvar
foreign import ccall "externalPutMVarFE"
externalPutMVarFE :: StablePtr (MVar ())
-> Int
-> IO ()
callbackPutMVar :: StablePtr (MVar ()) -> IO ()
callbackPutMVar sp = do
mvar <- deRefStablePtr sp
void $ tryPutMVar mvar ()
foreign export ccall callbackPutMVar :: StablePtr (MVar ()) -> IO ()
-- -----------------------------------------------------------------------------
-- Perform M copies of experiment1 concurrently
experiment2 :: Int -> IO () -> IO ()
experiment2 m exp = do
mvars <- replicateM m $ do
m <- newEmptyMVar
forkFinally exp (\_ -> putMVar m ())
return m
mapM_ takeMVar mvars
#include "HsFFI.h"
#include <unistd.h>
#include <pthread.h>
#include "hs_try_putmvar002_stub.h"
void externalPutMVar(HsStablePtr mvar, HsInt cap)
{
hs_try_putmvar(cap,mvar);
}
void externalPutMVarFE(HsStablePtr mvar, HsInt cap)
{
callbackPutMVar(mvar);
}
void externalManyPutMVars(HsStablePtr mvar, HsInt n, HsInt cap)
{
for (int i = 0; i < n; i++) {
hs_try_putmvar(cap,mvar);
}
}
void externalManyPutMVarsFE(HsStablePtr mvar, HsInt n, HsInt cap)
{
for (int i = 0; i < n; i++) {
callbackPutMVar(mvar);
}
}
{-# LANGUAGE MagicHash #-}
module Main where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Foreign hiding (void)
import Foreign.C
import GHC.Conc
import GHC.MVar (MVar(..))
import GHC.Prim
import System.Environment
-- Measure C to Haskell callback throughput under a workload with
-- several dimensions:
--
-- * X callback queues (each managed by an OS thread in C)
-- * each queue has Y Haskell threads, each making Z requests
--
-- And we can run the whole thing in two ways:
-- * With the callbacks calling into a foreign export
-- * With the callbacks using hs_try_putmvar()
--
-- Example results (using WAY=threaded2)
--
-- hs_try_putmvar003 1 64 16 500 +RTS -s -N4 1.10s
-- hs_try_putmvar003 2 64 16 500 +RTS -s -N4 9.88s
--
-- hs_try_putmvar() is 9x faster with these parameters.
main = do
args <- getArgs
case args of
["1",x,y,z] -> experiment False (read x) (read y) (read z)
["2",x,y,z] -> experiment True (read x) (read y) (read z)
makeExternalCall :: Ptr CallbackQueue -> IO CInt
makeExternalCall q = mask_ $ do
mvar <- newEmptyMVar
sp <- newStablePtrPrimMVar mvar
fp <- mallocForeignPtr
(cap,_) <- threadCapability =<< myThreadId
withForeignPtr fp $ \presult -> do
scheduleCallback q sp cap presult
takeMVar mvar `onException` forkIO (do takeMVar mvar; touchForeignPtr fp)
peek presult
data CallbackQueue
foreign import ccall "mkCallbackQueue"
mkCallbackQueue :: Int -> IO (Ptr CallbackQueue)
foreign import ccall "destroyCallbackQueue"
destroyCallbackQueue :: Ptr CallbackQueue -> IO ()
foreign import ccall "scheduleCallback"
scheduleCallback :: Ptr CallbackQueue
-> StablePtr PrimMVar
-> Int
-> Ptr CInt
-> IO ()
callbackPutMVar :: StablePtr PrimMVar -> IO ()
callbackPutMVar sp = do
mvar <- deRefStablePtr sp
void $ tryPutMVar (MVar (unsafeCoerce# mvar)) ()
foreign export ccall callbackPutMVar :: StablePtr PrimMVar -> IO ()
-- Make
-- * x callback queues, each with
-- * y threads, doing
-- * z requests each
experiment :: Bool -> Int -> Int -> Int -> IO ()
experiment use_foreign_export x y z = do
mvars <- replicateM x $ async $ do
bracket (mkCallbackQueue (fromEnum use_foreign_export))
destroyCallbackQueue $ \q -> do
mvars <- replicateM y $ async $
replicateM_ z $ void $ makeExternalCall q
mapM_ takeMVar mvars
mapM_ takeMVar mvars
async :: IO () -> IO (MVar ())
async io = do
m <- newEmptyMVar
forkFinally io (\_ -> putMVar m ())
return m
#include "HsFFI.h"
#include "Rts.h"
#include "RtsAPI.h"
#include <unistd.h>
#include <pthread.h>
#include "hs_try_putmvar003_stub.h"
struct callback_queue {
pthread_mutex_t lock;
pthread_cond_t cond;
int use_foreign_export;
struct callback *pending;
};
struct callback {
HsStablePtr mvar;
int cap;
int *presult;
struct callback *next;
};
void* callback(struct callback_queue *q)
{
struct callback *cb;
pthread_mutex_lock(&q->lock);
do {
if (q->pending == NULL) {
pthread_cond_wait(&q->cond,&q->lock);
}
if (q->pending != NULL) {
cb = q->pending;
q->pending = cb->next;
*cb->presult = 42;
if (q->use_foreign_export) {
callbackPutMVar(cb->mvar);
} else {
hs_try_putmvar(cb->cap,cb->mvar);
}
free(cb);
}
} while (1);
pthread_mutex_unlock(&q->lock);
hs_thread_done();
return NULL;
}
typedef void* threadfunc(void *);
struct callback_queue* mkCallbackQueue(int use_foreign_export)
{
struct callback_queue *q = malloc(sizeof(struct callback_queue));
pthread_t t;
pthread_mutex_init(&q->lock, NULL);
pthread_cond_init(&q->cond, NULL);
pthread_create(&t, NULL, (threadfunc*)callback, q);
q->pending = NULL;
q->use_foreign_export = use_foreign_export;
return q;
}
void destroyCallbackQueue(struct callback_queue *q)
{
pthread_mutex_destroy(&q->lock);
pthread_cond_destroy(&q->cond);
free(q);
}
void scheduleCallback(struct callback_queue *q,
HsStablePtr mvar,
HsInt cap, int *presult)
{
struct callback *p = malloc(sizeof(struct callback));
p->mvar = mvar;
p->cap = cap;
p->presult = presult;
pthread_mutex_lock(&q->lock);
p->next = q->pending;
q->pending = p;
pthread_cond_signal(&q->cond);
pthread_mutex_unlock(&q->lock);
}