projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Minor
[ghc-hetmet.git]
/
rts
/
Schedule.c
diff --git
a/rts/Schedule.c
b/rts/Schedule.c
index
5ed575e
..
f6a9ef2
100644
(file)
--- a/
rts/Schedule.c
+++ b/
rts/Schedule.c
@@
-1235,23
+1235,23
@@
scheduleHandleThreadFinished (Capability *cap STG_UNUSED, Task *task, StgTSO *t)
ASSERT(task->incall->tso == t);
if (t->what_next == ThreadComplete) {
ASSERT(task->incall->tso == t);
if (t->what_next == ThreadComplete) {
- if (task->ret) {
+ if (task->incall->ret) {
// NOTE: return val is tso->sp[1] (see StgStartup.hc)
// NOTE: return val is tso->sp[1] (see StgStartup.hc)
- *(task->ret) = (StgClosure *)task->incall->tso->sp[1];
+ *(task->incall->ret) = (StgClosure *)task->incall->tso->sp[1];
}
}
- task->stat = Success;
+ task->incall->stat = Success;
} else {
} else {
- if (task->ret) {
- *(task->ret) = NULL;
+ if (task->incall->ret) {
+ *(task->incall->ret) = NULL;
}
if (sched_state >= SCHED_INTERRUPTING) {
if (heap_overflow) {
}
if (sched_state >= SCHED_INTERRUPTING) {
if (heap_overflow) {
- task->stat = HeapExhausted;
+ task->incall->stat = HeapExhausted;
} else {
} else {
- task->stat = Interrupted;
+ task->incall->stat = Interrupted;
}
} else {
}
} else {
- task->stat = Killed;
+ task->incall->stat = Killed;
}
}
#ifdef DEBUG
}
}
#ifdef DEBUG
@@
-1533,10
+1533,14
@@
forkProcess(HsStablePtr *entry
ACQUIRE_LOCK(&cap->lock);
ACQUIRE_LOCK(&cap->running_task->lock);
ACQUIRE_LOCK(&cap->lock);
ACQUIRE_LOCK(&cap->running_task->lock);
+ stopTimer(); // See #4074
+
pid = fork();
if (pid) { // parent
pid = fork();
if (pid) { // parent
+ startTimer(); // #4074
+
RELEASE_LOCK(&sched_mutex);
RELEASE_LOCK(&cap->lock);
RELEASE_LOCK(&cap->running_task->lock);
RELEASE_LOCK(&sched_mutex);
RELEASE_LOCK(&cap->lock);
RELEASE_LOCK(&cap->running_task->lock);
@@
-1712,13
+1716,17
@@
recoverSuspendedTask (Capability *cap, Task *task)
* the whole system.
*
* The Haskell thread making the C call is put to sleep for the
* the whole system.
*
* The Haskell thread making the C call is put to sleep for the
- * duration of the call, on the susepended_ccalling_threads queue. We
+ * duration of the call, on the suspended_ccalling_threads queue. We
* give out a token to the task, which it can use to resume the thread
* on return from the C function.
* give out a token to the task, which it can use to resume the thread
* on return from the C function.
+ *
+ * If this is an interruptible C call, this means that the FFI call may be
+ * unceremoniously terminated and should be scheduled on an
+ * unbound worker thread.
* ------------------------------------------------------------------------- */
void *
* ------------------------------------------------------------------------- */
void *
-suspendThread (StgRegTable *reg)
+suspendThread (StgRegTable *reg, rtsBool interruptible)
{
Capability *cap;
int saved_errno;
{
Capability *cap;
int saved_errno;
@@
-1747,12
+1755,10
@@
suspendThread (StgRegTable *reg)
threadPaused(cap,tso);
threadPaused(cap,tso);
- if ((tso->flags & TSO_BLOCKEX) == 0) {
- tso->why_blocked = BlockedOnCCall;
- tso->flags |= TSO_BLOCKEX;
- tso->flags &= ~TSO_INTERRUPTIBLE;
+ if (interruptible) {
+ tso->why_blocked = BlockedOnCCall_Interruptible;
} else {
} else {
- tso->why_blocked = BlockedOnCCall_NoUnblockExc;
+ tso->why_blocked = BlockedOnCCall;
}
// Hand back capability
}
// Hand back capability
@@
-1811,17
+1817,16
@@
resumeThread (void *task_)
traceEventRunThread(cap, tso);
traceEventRunThread(cap, tso);
- if (tso->why_blocked == BlockedOnCCall) {
+ /* Reset blocking status */
+ tso->why_blocked = NotBlocked;
+
+ if ((tso->flags & TSO_BLOCKEX) == 0) {
// avoid locking the TSO if we don't have to
if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) {
// avoid locking the TSO if we don't have to
if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) {
- awakenBlockedExceptionQueue(cap,tso);
+ maybePerformBlockedException(cap,tso);
}
}
- tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
}
}
- /* Reset blocking status */
- tso->why_blocked = NotBlocked;
-
cap->r.rCurrentTSO = tso;
cap->in_haskell = rtsTrue;
errno = saved_errno;
cap->r.rCurrentTSO = tso;
cap->in_haskell = rtsTrue;
errno = saved_errno;
@@
-1887,8
+1892,8
@@
scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability *cap)
tso->cap = cap;
task->incall->tso = tso;
tso->cap = cap;
task->incall->tso = tso;
- task->ret = ret;
- task->stat = NoStatus;
+ task->incall->ret = ret;
+ task->incall->stat = NoStatus;
appendToRunQueue(cap,tso);
appendToRunQueue(cap,tso);
@@
-1897,7
+1902,7
@@
scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability *cap)
cap = schedule(cap,task);
cap = schedule(cap,task);
- ASSERT(task->stat != NoStatus);
+ ASSERT(task->incall->stat != NoStatus);
ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
debugTrace(DEBUG_sched, "bound thread (%lu) finished", (unsigned long)id);
ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
debugTrace(DEBUG_sched, "bound thread (%lu) finished", (unsigned long)id);
@@
-1997,12
+2002,7
@@
initScheduler(void)
}
void
}
void
-exitScheduler(
- rtsBool wait_foreign
-#if !defined(THREADED_RTS)
- __attribute__((unused))
-#endif
-)
+exitScheduler (rtsBool wait_foreign USED_IF_THREADS)
/* see Capability.c, shutdownCapability() */
{
Task *task = NULL;
/* see Capability.c, shutdownCapability() */
{
Task *task = NULL;
@@
-2332,7
+2332,7
@@
deleteThread (Capability *cap STG_UNUSED, StgTSO *tso)
// we must own all Capabilities.
if (tso->why_blocked != BlockedOnCCall &&
// we must own all Capabilities.
if (tso->why_blocked != BlockedOnCCall &&
- tso->why_blocked != BlockedOnCCall_NoUnblockExc) {
+ tso->why_blocked != BlockedOnCCall_Interruptible) {
throwToSingleThreaded(tso->cap,tso,NULL);
}
}
throwToSingleThreaded(tso->cap,tso,NULL);
}
}
@@
-2344,7
+2344,7
@@
deleteThread_(Capability *cap, StgTSO *tso)
// like deleteThread(), but we delete threads in foreign calls, too.
if (tso->why_blocked == BlockedOnCCall ||
// like deleteThread(), but we delete threads in foreign calls, too.
if (tso->why_blocked == BlockedOnCCall ||
- tso->why_blocked == BlockedOnCCall_NoUnblockExc) {
+ tso->why_blocked == BlockedOnCCall_Interruptible) {
tso->what_next = ThreadKilled;
appendToRunQueue(tso->cap, tso);
} else {
tso->what_next = ThreadKilled;
appendToRunQueue(tso->cap, tso);
} else {