/* if this flag is set as well, give up execution */
rtsBool interrupted = rtsFalse;
+/* If this flag is set, we are running Haskell code. Used to detect
+ * uses of 'foreign import unsafe' that should be 'safe'.
+ */
+rtsBool in_haskell = rtsFalse;
+
/* Next thread ID to allocate.
* Locks required: thread_id_mutex
*/
static void schedule ( StgMainThread *mainThread, Capability *initialCapability );
void interruptStgRts ( void );
-#if !defined(PAR) && !defined(RTS_SUPPORTS_THREADS)
-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
// We now have a capability...
#endif
+ // Check whether we have re-entered the RTS from Haskell without
+ // going via suspendThread()/resumeThread (i.e. a 'safe' foreign
+ // call).
+ if (in_haskell) {
+ errorBelch("schedule: re-entered unsafely.\n"
+ " Perhaps a 'foreign import unsafe' should be 'safe'?");
+ stg_exit(1);
+ }
+
//
// If we're interrupted (the user pressed ^C, or some other
// termination condition occurred), kill all the currently running
// 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
}
prev_what_next = t->what_next;
errno = t->saved_errno;
+ in_haskell = rtsTrue;
switch (prev_what_next) {
barf("schedule: invalid what_next field");
}
+ in_haskell = rtsFalse;
+
// The TSO might have moved, so find the new location:
t = cap->r.rCurrentTSO;
#endif
ready_to_gc = rtsTrue;
- context_switch = 1; /* stop other threads ASAP */
PUSH_ON_RUN_QUEUE(t);
/* actual GC is done at the end of the while loop */
break;
* 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
IF_DEBUG(scheduler, sched_belch("worker (token %d): leaving RTS", tok));
#endif
+ in_haskell = rtsFalse;
RELEASE_LOCK(&sched_mutex);
errno = saved_errno;
tso->why_blocked = NotBlocked;
cap->r.rCurrentTSO = tso;
+ in_haskell = rtsTrue;
RELEASE_LOCK(&sched_mutex);
errno = saved_errno;
return &cap->r;
tso->link = dest;
tso->sp = (P_)&(tso->stack[tso->stack_size]);
tso->why_blocked = NotBlocked;
- dest->mut_link = NULL;
IF_PAR_DEBUG(verbose,
debugBelch("@@ threadStackOverflow of TSO %d (now at %p): stack size increased to %ld\n",
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
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