static void detectBlackHoles ( void );
#endif
+static void raiseAsync_(StgTSO *tso, StgClosure *exception, rtsBool stop_at_atomically);
+
#if defined(RTS_SUPPORTS_THREADS)
/* ToDo: carefully document the invariants that go together
* with these synchronisation objects.
// ToDo: add deadlock detection in GUM (similar to SMP) -- HWL
#endif
-#if defined(RTS_SUPPORTS_THREADS)
+#if defined(RTS_SUPPORTS_THREADS) || defined(mingw32_HOST_OS)
+ /* win32: might be back here due to awaitEvent() being abandoned
+ * as a result of a console event having been delivered.
+ */
if ( EMPTY_RUN_QUEUE() ) {
continue; // nothing to do
}
* previously, or it's blocked on an MVar or Blackhole, in which
* case it'll be on the relevant queue already.
*/
+ ASSERT(t->why_blocked != NotBlocked);
IF_DEBUG(scheduler,
debugBelch("--<< thread %d (%s) stopped: ",
t->id, whatNext_strs[t->what_next]);
* When next scheduled they will try to commit, this commit will fail and
* they will retry. */
for (t = all_threads; t != END_TSO_QUEUE; t = t -> link) {
- if (t -> trec != NO_TREC && t -> why_blocked == NotBlocked) {
+ if (t -> what_next != ThreadRelocated && t -> trec != NO_TREC && t -> why_blocked == NotBlocked) {
if (!stmValidateTransaction (t -> trec)) {
- StgRetInfoTable *info;
- StgPtr sp = t -> sp;
-
IF_DEBUG(stm, sched_belch("trec %p found wasting its time", t));
- if (sp[0] == (W_)&stg_enter_info) {
- sp++;
- } else {
- sp--;
- sp[0] = (W_)&stg_dummy_ret_closure;
- }
-
- // Look up the stack for its atomically frame
- StgPtr frame;
- frame = sp + 1;
- info = get_ret_itbl((StgClosure *)frame);
-
- while (info->i.type != ATOMICALLY_FRAME &&
- info->i.type != STOP_FRAME &&
- info->i.type != UPDATE_FRAME) {
- if (info -> i.type == CATCH_RETRY_FRAME) {
- IF_DEBUG(stm, sched_belch("Aborting transaction in catch-retry frame"));
- stmAbortTransaction(t -> trec);
- t -> trec = stmGetEnclosingTRec(t -> trec);
- }
- frame += stack_frame_sizeW((StgClosure *)frame);
- info = get_ret_itbl((StgClosure *)frame);
- }
+ // strip the stack back to the ATOMICALLY_FRAME, aborting
+ // the (nested) transaction, and saving the stack of any
+ // partially-evaluated thunks on the heap.
+ raiseAsync_(t, NULL, rtsTrue);
- if (!info -> i.type == ATOMICALLY_FRAME) {
- barf("Could not find ATOMICALLY_FRAME for unvalidatable thread");
- }
-
- // Cause the thread to enter its atomically frame again when
- // scheduled -- this will attempt stmCommitTransaction or stmReWait
- // which will fail triggering re-rexecution.
- t->sp = frame;
- t->what_next = ThreadRunGHC;
+#ifdef REG_R1
+ ASSERT(get_itbl((StgClosure *)t->sp)->type == ATOMICALLY_FRAME);
+#endif
}
}
}
* Singleton fork(). Do not copy any running threads.
* ------------------------------------------------------------------------- */
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
#define FORKPROCESS_PRIMOP_SUPPORTED
#endif
case BlockedOnRead:
case BlockedOnWrite:
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
case BlockedOnDoProc:
#endif
{
case BlockedOnRead:
case BlockedOnWrite:
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
case BlockedOnDoProc:
#endif
{
void
deleteThread(StgTSO *tso)
{
- raiseAsync(tso,NULL);
+ if (tso->why_blocked != BlockedOnCCall &&
+ tso->why_blocked != BlockedOnCCall_NoUnblockExc) {
+ raiseAsync(tso,NULL);
+ }
}
#ifdef FORKPROCESS_PRIMOP_SUPPORTED
void
raiseAsync(StgTSO *tso, StgClosure *exception)
{
+ raiseAsync_(tso, exception, rtsFalse);
+}
+
+static void
+raiseAsync_(StgTSO *tso, StgClosure *exception, rtsBool stop_at_atomically)
+{
StgRetInfoTable *info;
StgPtr sp;
while (info->i.type != UPDATE_FRAME
&& (info->i.type != CATCH_FRAME || exception == NULL)
- && info->i.type != STOP_FRAME) {
- if (info->i.type == ATOMICALLY_FRAME) {
+ && info->i.type != STOP_FRAME
+ && (info->i.type != ATOMICALLY_FRAME || stop_at_atomically == rtsFalse))
+ {
+ if (info->i.type == CATCH_RETRY_FRAME || info->i.type == ATOMICALLY_FRAME) {
// IF we find an ATOMICALLY_FRAME then we abort the
// current transaction and propagate the exception. In
// this case (unlike ordinary exceptions) we do not care
switch (info->i.type) {
+ case ATOMICALLY_FRAME:
+ ASSERT(stop_at_atomically);
+ ASSERT(stmGetEnclosingTRec(tso->trec) == NO_TREC);
+ stmCondemnTransaction(tso -> trec);
+#ifdef REG_R1
+ tso->sp = frame;
+#else
+ // R1 is not a register: the return convention for IO in
+ // this case puts the return value on the stack, so we
+ // need to set up the stack to return to the atomically
+ // frame properly...
+ tso->sp = frame - 2;
+ tso->sp[1] = (StgWord) &stg_NO_FINALIZER_closure; // why not?
+ tso->sp[0] = (StgWord) &stg_ut_1_0_unreg_info;
+#endif
+ tso->what_next = ThreadRunGHC;
+ return;
+
case CATCH_FRAME:
// If we find a CATCH_FRAME, and we've got an exception to raise,
// then build the THUNK raise(exception), and leave it on
}
}
}
-
+
/* -----------------------------------------------------------------------------
resurrectThreads is called after garbage collection on the list of
threads found to be garbage. Each of these threads will be woken
case BlockedOnWrite:
debugBelch("is blocked on write to fd %d", tso->block_info.fd);
break;
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
case BlockedOnDoProc:
debugBelch("is blocked on proc (request: %d)", tso->block_info.async_result->reqID);
break;
projects / ghc-hetmet.git / blobdiff