[commit: ghc] ghc-lwc: MessageBlackHole takes tso instead of upcall. This will eventually allow upcall threads to block on blackhole. (cc5962c)
Sivaramakrishnan Krishnamoorthy Chandrasekaran
kc at galois.com
Sat May 12 17:39:18 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : ghc-lwc
http://hackage.haskell.org/trac/ghc/changeset/cc5962c88a830f23e6b62ac2a7e6df19e9ec96b8
>---------------------------------------------------------------
commit cc5962c88a830f23e6b62ac2a7e6df19e9ec96b8
Author: kc <chandras at cs.purdue.edu>
Date: Thu May 10 15:17:17 2012 -0400
MessageBlackHole takes tso instead of upcall. This will eventually allow upcall threads to block on blackhole.
>---------------------------------------------------------------
includes/mkDerivedConstants.c | 2 +-
includes/rts/storage/Closures.h | 2 +-
rts/Messages.c | 17 ++++++++---------
rts/StgMiscClosures.cmm | 24 ++++++------------------
rts/Threads.c | 7 +++++--
5 files changed, 21 insertions(+), 31 deletions(-)
diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c
index f916f0e..229bbc8 100644
--- a/includes/mkDerivedConstants.c
+++ b/includes/mkDerivedConstants.c
@@ -413,7 +413,7 @@ main(int argc, char *argv[])
closure_size(MessageBlackHole);
closure_field(MessageBlackHole, link);
- closure_field(MessageBlackHole, upcall);
+ closure_field(MessageBlackHole, tso);
closure_field(MessageBlackHole, bh);
struct_field_("RtsFlags_ProfFlags_showCCSOnException",
diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h
index 6484e29..9b3213b 100644
--- a/includes/rts/storage/Closures.h
+++ b/includes/rts/storage/Closures.h
@@ -461,7 +461,7 @@ typedef struct MessageThrowTo_ {
typedef struct MessageBlackHole_ {
StgHeader header;
struct MessageBlackHole_ *link;
- StgClosure *upcall;
+ StgTSO *tso;
StgClosure *bh;
} MessageBlackHole;
diff --git a/rts/Messages.c b/rts/Messages.c
index 1d81258..4adea3f 100644
--- a/rts/Messages.c
+++ b/rts/Messages.c
@@ -117,9 +117,8 @@ loop:
MessageBlackHole *b = (MessageBlackHole*)m;
r = messageBlackHole(cap, b);
- if (r == 0) {
- pushUpcallReturning (cap, b->upcall);
- }
+ if (r == 0)
+ tryWakeupThread (cap, b->tso);
return;
}
else if (i == &stg_IND_info || i == &stg_MSG_NULL_info)
@@ -166,8 +165,8 @@ nat messageBlackHole(Capability *cap, MessageBlackHole *msg)
StgClosure *bh = UNTAG_CLOSURE(msg->bh);
StgTSO *owner;
- debugTraceCap(DEBUG_sched, cap, "message: upcall %p blocking on blackhole %p",
- msg->upcall, msg->bh);
+ debugTraceCap(DEBUG_sched, cap, "message: thread %d blocking on blackhole %p",
+ msg->tso->id, msg->bh);
info = bh->header.info;
@@ -241,8 +240,8 @@ loop:
((StgInd*)bh)->indirectee = (StgClosure *)bq;
recordClosureMutated(cap,bh); // bh was mutated
- debugTraceCap(DEBUG_sched, cap, "upcall %p blocked on thread %d",
- msg->upcall, (lnat)owner->id);
+ debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d",
+ msg->tso->id, (lnat)owner->id);
return 1; // blocked
}
@@ -274,8 +273,8 @@ loop:
recordClosureMutated(cap,(StgClosure*)bq);
}
- debugTraceCap(DEBUG_sched, cap, "upcall %p blocked on thread %d",
- msg->upcall, (lnat)owner->id);
+ debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d",
+ msg->tso->id, (lnat)owner->id);
return 1; // blocked
}
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index a3239d3..79ec7a1 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -273,12 +273,12 @@ INFO_TABLE(stg_IND_PERM,1,0,IND_PERM,"IND_PERM","IND_PERM")
INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
{
- W_ r, p, info, bq, msg, owner, bd, uc, buct;
+ W_ r, p, info, bq;
+ W_ msg, owner, bd, uc;
+ W_ buct, trec;
TICK_ENT_DYN_IND(); /* tick */
- uc = 0;
-
retry:
p = StgInd_indirectee(R1);
if (GETTAG(p) != 0) {
@@ -298,25 +298,13 @@ retry:
info == stg_BLOCKING_QUEUE_CLEAN_info ||
info == stg_BLOCKING_QUEUE_DIRTY_info)
{
+ trec = StgTSO_trec (CurrentTSO);
+ ASSERT (trec == NO_TREC);
("ptr" msg) = foreign "C" allocate(MyCapability() "ptr",
BYTES_TO_WDS(SIZEOF_MessageBlackHole)) [R1];
SET_HDR(msg, stg_MSG_BLACKHOLE_info, CCS_SYSTEM);
- if (uc == 0) {
- buct = TO_W_(StgTSO_is_upcall_thread(CurrentTSO));
- if (buct == 1) {
- foreign "C" barf ("Upcall thread entered blackhole!");
- //uc = StgTSO_finalizer (CurrentTSO);
-
- //(1) Am I in the middle of unblock_action or block_action??
- //(2) Should I additionally abort transaction here?? -- KC
- }
- else {
- ("ptr" uc) = foreign "C" getResumeThreadUpcall (MyCapability() "ptr",
- CurrentTSO "ptr") [R1];
- }
- }
- MessageBlackHole_upcall(msg) = uc;
+ MessageBlackHole_tso(msg) = CurrentTSO;
MessageBlackHole_bh(msg) = R1;
(r) = foreign "C" messageBlackHole(MyCapability() "ptr", msg "ptr") [R1];
diff --git a/rts/Threads.c b/rts/Threads.c
index 0730f66..0a6a863 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -311,7 +311,10 @@ tryWakeupThread (Capability *cap, StgTSO *tso)
}
case BlockedOnBlackHole:
- goto unblock1;
+ if (hasHaskellScheduler (tso)) //Note: Upcall threads do not have a user-level scheduler
+ goto unblock1;
+ else
+ goto unblock2;
case BlockedOnSTM:
goto unblock2;
@@ -414,7 +417,7 @@ wakeBlockingQueue(Capability *cap, StgBlockingQueue *bq)
i = msg->header.info;
if (i != &stg_IND_info) {
ASSERT(i == &stg_MSG_BLACKHOLE_info);
- pushUpcallReturning (cap, msg->upcall);
+ tryWakeupThread (cap, msg->tso);
}
}
More information about the Cvs-ghc
mailing list