Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-lwc
http://hackage.haskell.org/trac/ghc/changeset/cc5962c88a830f23e6b62ac2a7e6df19e9ec96b8 >--------------------------------------------------------------- commit cc5962c88a830f23e6b62ac2a7e6df19e9ec96b8 Author: kc <[email protected]> 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); } } _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
