[commit: ghc] ghc-lwc2: Fixing issue from an earlier merge which removed the code for inheriting computation on a black-hole. Fixed findLastUpdateFrame and printStackFrames function to handle underflow frame. Substrate upcall errors are printed to stderr. (3b170a4)
Sivaramakrishnan Krishnamoorthy Chandrasekaran
t-sichan at microsoft.com
Fri Mar 1 06:58:39 CET 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : ghc-lwc2
http://hackage.haskell.org/trac/ghc/changeset/3b170a4a89ca00bdbef1517b446f450f5a1ac31c
>---------------------------------------------------------------
commit 3b170a4a89ca00bdbef1517b446f450f5a1ac31c
Author: KC Sivaramakrishnan <chandras at cs.purdue.edu>
Date: Fri Mar 1 00:10:12 2013 -0500
Fixing issue from an earlier merge which removed the code for inheriting computation on a black-hole. Fixed findLastUpdateFrame and printStackFrames function to handle underflow frame. Substrate upcall errors are printed to stderr.
>---------------------------------------------------------------
libraries/base/LwConc/Substrate.hs | 5 +++--
rts/RaiseAsync.c | 11 +++++++++--
rts/Schedule.c | 10 +++++++---
rts/StgMiscClosures.cmm | 9 +++++++++
rts/Threads.c | 15 +++++++++++----
5 files changed, 39 insertions(+), 11 deletions(-)
diff --git a/libraries/base/LwConc/Substrate.hs b/libraries/base/LwConc/Substrate.hs
index 30e447d..af12ed7 100644
--- a/libraries/base/LwConc/Substrate.hs
+++ b/libraries/base/LwConc/Substrate.hs
@@ -157,6 +157,7 @@ import GHC.IO
import Control.Monad ( when )
#endif
+import System.IO
import GHC.Conc (yield, childHandler, getNumCapabilities)
import Data.Typeable
import Data.Dynamic
@@ -427,7 +428,7 @@ yieldControlActionRts sc = Exception.catch (atomically $ do
otherwise -> error "yieldControlAction: Impossible status"
switch <- getYieldControlActionSCont sc
switch) (\e -> do {
- print ("ERROR:" ++ show (e::IOException));
+ hPutStrLn stderr ("ERROR:" ++ show (e::IOException));
error "LwConc.Substrate.yieldControlActionRTS"
})
@@ -462,7 +463,7 @@ scheduleSContActionRts sc = Exception.catch (atomically $ do
setSContStatus sc $ SContSwitched Yielded
unblock <- getScheduleSContActionSCont sc
unblock sc) (\e -> do {
- print ("ERROR:" ++ show (e::IOException));
+ hPutStrLn stderr ("ERROR:" ++ show (e::IOException));
error "LwConc.Substrate.scheduleSContActionRTS"
})
diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index 9e35204..56c7b1f 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -76,7 +76,7 @@ throwToSingleThreaded__ (Capability *cap, StgTSO *tso, StgClosure *exception,
removeFromQueues(cap,tso);
raiseAsync(cap, tso, exception, stop_at_atomically,
- stop_here_excluding, stop_here_including);
+ stop_here_excluding, stop_here_including);
}
void
@@ -145,7 +145,14 @@ findLastUpdateFrame (StgTSO* tso) {
ret_frame = frame;
break;
- case UNDERFLOW_FRAME:
+ case UNDERFLOW_FRAME: {
+ debugTrace (DEBUG_sched, "findLastUpdateFrame saw underflow");
+ ASSERT(((StgUnderflowFrame*)frame)->info == &stg_stack_underflow_frame_info);
+ stack = (StgStack*)((StgUnderflowFrame*)frame)->next_chunk;
+ sp = stack->sp;
+ frame = sp;
+ continue;
+ }
case STOP_FRAME:
case CATCH_FRAME:
case ATOMICALLY_FRAME:
diff --git a/rts/Schedule.c b/rts/Schedule.c
index b3df6f0..e95d470 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -537,9 +537,14 @@ run_thread:
//Handle upcall thread return
if (isUpcallThread (t)) {
- if (t->what_next == ThreadKilled && sched_state != SCHED_SHUTTING_DOWN)
- barf ("Schedule: Upcall thread %d on capability %d killed\n",
+ /* The programs seem to work correctly under certain conditions
+ * when the upcall thread may have been killed. Hence, commented it
+ * out. Why and where it happens is still a mystery?
+ */
+ if (t->what_next == ThreadKilled && sched_state != SCHED_SHUTTING_DOWN) {
+ debugTrace (DEBUG_sched, "Schedule: Upcall thread %d on capability %d killed\n",
(int)t->id, (int)t->cap->no);
+ }
if (ret == ThreadFinished) {
t->what_next = ThreadComplete;
@@ -558,7 +563,6 @@ run_thread:
ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
}
#endif
-
// ----------------------------------------------------------------------
// Costs for the scheduler are assigned to CCS_SYSTEM
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 28a41ad..fe8a25b 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -308,6 +308,7 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
{
W_ r, info, owner, bd;
P_ p, bq, msg;
+ gcptr trec;
TICK_ENT_DYN_IND(); /* tick */
@@ -329,6 +330,14 @@ retry:
info == stg_BLOCKING_QUEUE_CLEAN_info ||
info == stg_BLOCKING_QUEUE_DIRTY_info)
{
+ trec = StgTSO_trec (CurrentTSO);
+ if (trec != NO_TREC && StgTSO_is_upcall_thread (CurrentTSO) != 0::I32) {
+ (p) = ccall suspendAllComputation (MyCapability () "ptr", node "ptr");
+ if (p != 0) {
+ goto retry;
+ }
+ }
+
("ptr" msg) = ccall allocate(MyCapability() "ptr",
BYTES_TO_WDS(SIZEOF_MessageBlackHole));
diff --git a/rts/Threads.c b/rts/Threads.c
index 2421e8d..a4b01d9 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -487,7 +487,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso)
awaken any threads that are blocked on it.
------------------------------------------------------------------------- */
- void
+void
updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val)
{
StgClosure *v;
@@ -896,6 +896,9 @@ printThreadStatus(StgTSO *t)
if (t->dirty) {
debugBelch(" (TSO_DIRTY)");
}
+ if (t->is_sleeping) {
+ debugBelch(" (SLEEPING)");
+ }
debugBelch("\n");
}
@@ -968,9 +971,13 @@ printStackFrames (StgTSO* tso) {
}
case UNDERFLOW_FRAME: {
- fprintf (stderr, "UNDERFLOW\tframe %p\n", frame);
- break;
- }
+ fprintf (stderr, "UNDERFLOW\tframe %p\n", frame);
+ ASSERT(((StgUnderflowFrame*)frame)->info == &stg_stack_underflow_frame_info);
+ stack = (StgStack*)((StgUnderflowFrame*)frame)->next_chunk;
+ sp = stack->sp;
+ frame = sp;
+ continue;
+ }
case STOP_FRAME: {
fprintf (stderr, "STOP\t\tframe %p\n", frame);
More information about the ghc-commits
mailing list