Updating a thunk in raiseAsync might encounter an IND; cope

[ghc-hetmet.git] / rts / RaiseAsync.c

diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index 9041c06..21bc78e 100644 (file)
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -13,10 +13,14 @@
 #include "RaiseAsync.h"
 #include "SMP.h"
 #include "Schedule.h"
 #include "RaiseAsync.h"
 #include "SMP.h"
 #include "Schedule.h"

-#include "Storage.h"
+#include "LdvProfile.h"

 #include "Updates.h"
 #include "STM.h"
 #include "Sanity.h"
 #include "Updates.h"
 #include "STM.h"
 #include "Sanity.h"

+#include "Profiling.h"
+#if defined(mingw32_HOST_OS)
+#include "win32/IOManager.h"
+#endif

 
 static void raiseAsync (Capability *cap,
                        StgTSO *tso,
 
 static void raiseAsync (Capability *cap,
                        StgTSO *tso,

@@ -153,8 +157,8 @@ throwTo (Capability *cap,   // the Capability we hold
        // ASSERT(get_itbl(target)->type == TSO);
     }
 
        // ASSERT(get_itbl(target)->type == TSO);
     }
 

-    debugTrace(DEBUG_sched, "throwTo: from thread %d to thread %d",
-              source->id, target->id);
+    debugTrace(DEBUG_sched, "throwTo: from thread %lu to thread %lu",
+              (unsigned long)source->id, (unsigned long)target->id);

 
 #ifdef DEBUG
     if (traceClass(DEBUG_sched)) {
 
 #ifdef DEBUG
     if (traceClass(DEBUG_sched)) {

@@ -240,7 +244,7 @@ check_target:
     {
        Capability *target_cap;
 
     {
        Capability *target_cap;
 

-       wb();
+       write_barrier();

        target_cap = target->cap;
        if (target_cap == cap && (target->flags & TSO_BLOCKEX) == 0) {
            // It's on our run queue and not blocking exceptions
        target_cap = target->cap;
        if (target_cap == cap && (target->flags & TSO_BLOCKEX) == 0) {
            // It's on our run queue and not blocking exceptions

@@ -279,7 +283,13 @@ check_target:
 
        // ASSUMPTION: tso->block_info must always point to a
        // closure.  In the threaded RTS it does.
 
        // ASSUMPTION: tso->block_info must always point to a
        // closure.  In the threaded RTS it does.

-       if (get_itbl(mvar)->type != MVAR) goto retry;
+        switch (get_itbl(mvar)->type) {
+        case MVAR_CLEAN:
+        case MVAR_DIRTY:
+            break;
+        default:
+            goto retry;
+        }

 
        info = lockClosure((StgClosure *)mvar);
 
 
        info = lockClosure((StgClosure *)mvar);
 

@@ -401,7 +411,23 @@ check_target:
     }  
 
     case BlockedOnSTM:
     }  
 
     case BlockedOnSTM:

-       barf("ToDo");
+       lockTSO(target);
+       // Unblocking BlockedOnSTM threads requires the TSO to be
+       // locked; see STM.c:unpark_tso().
+       if (target->why_blocked != BlockedOnSTM) {
+           goto retry;
+       }
+       if ((target->flags & TSO_BLOCKEX) &&
+           ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
+           blockedThrowTo(source,target);
+           *out = target;
+           return THROWTO_BLOCKED;
+       } else {
+           raiseAsync(cap, target, exception, rtsFalse, NULL);
+           unblockOne(cap, target);
+           unlockTSO(target);
+           return THROWTO_SUCCESS;
+       }

 
     case BlockedOnCCall:
     case BlockedOnCCall_NoUnblockExc:
 
     case BlockedOnCCall:
     case BlockedOnCCall_NoUnblockExc:

@@ -418,6 +444,9 @@ check_target:
     case BlockedOnRead:
     case BlockedOnWrite:
     case BlockedOnDelay:
     case BlockedOnRead:
     case BlockedOnWrite:
     case BlockedOnDelay:

+#if defined(mingw32_HOST_OS)
+    case BlockedOnDoProc:
+#endif

        if ((target->flags & TSO_BLOCKEX) &&
            ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
            blockedThrowTo(source,target);
        if ((target->flags & TSO_BLOCKEX) &&
            ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
            blockedThrowTo(source,target);

@@ -442,13 +471,13 @@ check_target:
 static void
 blockedThrowTo (StgTSO *source, StgTSO *target)
 {
 static void
 blockedThrowTo (StgTSO *source, StgTSO *target)
 {

-    debugTrace(DEBUG_sched, "throwTo: blocking on thread %d", target->id);
+    debugTrace(DEBUG_sched, "throwTo: blocking on thread %lu", (unsigned long)target->id);

     source->link = target->blocked_exceptions;
     target->blocked_exceptions = source;
     dirtyTSO(target); // we modified the blocked_exceptions queue
     
     source->block_info.tso = target;
     source->link = target->blocked_exceptions;
     target->blocked_exceptions = source;
     dirtyTSO(target); // we modified the blocked_exceptions queue
     
     source->block_info.tso = target;

-    wb(); // throwTo_exception *must* be visible if BlockedOnException is.
+    write_barrier(); // throwTo_exception *must* be visible if BlockedOnException is.

     source->why_blocked = BlockedOnException;
 }
 
     source->why_blocked = BlockedOnException;
 }
 

@@ -474,13 +503,20 @@ throwToReleaseTarget (void *tso)
    queue, but not perform any throwTo() immediately.  This might be
    more appropriate when the target thread is the one actually running
    (see Exception.cmm).
    queue, but not perform any throwTo() immediately.  This might be
    more appropriate when the target thread is the one actually running
    (see Exception.cmm).

+
+   Returns: non-zero if an exception was raised, zero otherwise.

    -------------------------------------------------------------------------- */
 
    -------------------------------------------------------------------------- */
 

-void
+int

 maybePerformBlockedException (Capability *cap, StgTSO *tso)
 {
     StgTSO *source;
     
 maybePerformBlockedException (Capability *cap, StgTSO *tso)
 {
     StgTSO *source;
     

+    if (tso->blocked_exceptions != END_TSO_QUEUE && 
+        (tso->flags & TSO_BLOCKEX) != 0) {
+        debugTrace(DEBUG_sched, "throwTo: thread %lu has blocked exceptions but is inside block", (unsigned long)tso->id);
+    }
+

     if (tso->blocked_exceptions != END_TSO_QUEUE
        && ((tso->flags & TSO_BLOCKEX) == 0
            || ((tso->flags & TSO_INTERRUPTIBLE) && interruptible(tso)))) {
     if (tso->blocked_exceptions != END_TSO_QUEUE
        && ((tso->flags & TSO_BLOCKEX) == 0
            || ((tso->flags & TSO_INTERRUPTIBLE) && interruptible(tso)))) {

@@ -492,7 +528,7 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso)
        // locked it.
        if (tso->blocked_exceptions == END_TSO_QUEUE) {
            unlockTSO(tso);
        // locked it.
        if (tso->blocked_exceptions == END_TSO_QUEUE) {
            unlockTSO(tso);

-           return;
+           return 0;

        }
 
        // We unblock just the first thread on the queue, and perform
        }
 
        // We unblock just the first thread on the queue, and perform

@@ -502,7 +538,9 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso)
        tso->blocked_exceptions = unblockOne_(cap, source, 
                                              rtsFalse/*no migrate*/);
        unlockTSO(tso);
        tso->blocked_exceptions = unblockOne_(cap, source, 
                                              rtsFalse/*no migrate*/);
        unlockTSO(tso);

+        return 1;

     }
     }

+    return 0;

 }
 
 void
 }
 
 void

@@ -682,7 +720,7 @@ removeFromQueues(Capability *cap, StgTSO *tso)
     }
 
   default:
     }
 
   default:

-    barf("removeFromQueues");
+    barf("removeFromQueues: %d", tso->why_blocked);

   }
 
  done:
   }
 
  done:

@@ -755,7 +793,7 @@ removeFromQueues(Capability *cap, StgTSO *tso)
 #endif
 
   default:
 #endif
 
   default:

-      barf("removeFromQueues");
+      barf("removeFromQueues: %d", tso->why_blocked);

   }
 
  done:
   }
 
  done:

@@ -820,6 +858,18 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
     debugTrace(DEBUG_sched,
               "raising exception in thread %ld.", (long)tso->id);
     
     debugTrace(DEBUG_sched,
               "raising exception in thread %ld.", (long)tso->id);
     

+#if defined(PROFILING)
+    /* 
+     * Debugging tool: on raising an  exception, show where we are.
+     * See also Exception.cmm:raisezh_fast.
+     * This wasn't done for asynchronous exceptions originally; see #1450 
+     */
+    if (RtsFlags.ProfFlags.showCCSOnException)
+    {
+        fprintCCS_stderr(tso->prof.CCCS);
+    }
+#endif
+

     // mark it dirty; we're about to change its stack.
     dirtyTSO(tso);
 
     // mark it dirty; we're about to change its stack.
     dirtyTSO(tso);
 

@@ -894,21 +944,12 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
            //       printObj((StgClosure *)ap);
            //  );
 
            //       printObj((StgClosure *)ap);
            //  );
 

-           // Replace the updatee with an indirection
-           //
-           // Warning: if we're in a loop, more than one update frame on
-           // the stack may point to the same object.  Be careful not to
-           // overwrite an IND_OLDGEN in this case, because we'll screw
-           // up the mutable lists.  To be on the safe side, don't
-           // overwrite any kind of indirection at all.  See also
-           // threadSqueezeStack in GC.c, where we have to make a similar
-           // check.
-           //
-           if (!closure_IND(((StgUpdateFrame *)frame)->updatee)) {
-               // revert the black hole
-               UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,
-                              (StgClosure *)ap);
-           }
+            // Perform the update
+            // TODO: this may waste some work, if the thunk has
+            // already been updated by another thread.
+            UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,
+                           (StgClosure *)ap);
+

            sp += sizeofW(StgUpdateFrame) - 1;
            sp[0] = (W_)ap; // push onto stack
            frame = sp + 1;
            sp += sizeofW(StgUpdateFrame) - 1;
            sp[0] = (W_)ap; // push onto stack
            frame = sp + 1;

@@ -916,10 +957,12 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
        }
 
        case STOP_FRAME:
        }
 
        case STOP_FRAME:

+       {

            // We've stripped the entire stack, the thread is now dead.
            tso->what_next = ThreadKilled;
            tso->sp = frame + sizeofW(StgStopFrame);
            return;
            // We've stripped the entire stack, the thread is now dead.
            tso->what_next = ThreadKilled;
            tso->sp = frame + sizeofW(StgStopFrame);
            return;

+       }

 
        case CATCH_FRAME:
            // If we find a CATCH_FRAME, and we've got an exception to raise,
 
        case CATCH_FRAME:
            // If we find a CATCH_FRAME, and we've got an exception to raise,

@@ -991,14 +1034,17 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
            // whether the transaction is valid or not because its
            // possible validity cannot have caused the exception
            // and will not be visible after the abort.
            // whether the transaction is valid or not because its
            // possible validity cannot have caused the exception
            // and will not be visible after the abort.

-           debugTrace(DEBUG_stm, 
-                      "found atomically block delivering async exception");

 
 

+               {

             StgTRecHeader *trec = tso -> trec;
             StgTRecHeader *outer = stmGetEnclosingTRec(trec);
             StgTRecHeader *trec = tso -> trec;
             StgTRecHeader *outer = stmGetEnclosingTRec(trec);

+           debugTrace(DEBUG_stm, 
+                      "found atomically block delivering async exception");

             stmAbortTransaction(cap, trec);
             stmAbortTransaction(cap, trec);

+           stmFreeAbortedTRec(cap, trec);

             tso -> trec = outer;
            break;
             tso -> trec = outer;
            break;

+           };

            
        default:
            break;
            
        default:
            break;