allow PAPI to be installed somewhere non-standard
[ghc-hetmet.git] / rts / RaiseAsync.c
1 /* ---------------------------------------------------------------------------
2  *
3  * (c) The GHC Team, 1998-2006
4  *
5  * Asynchronous exceptions
6  *
7  * --------------------------------------------------------------------------*/
8
9 #include "PosixSource.h"
10 #include "Rts.h"
11 #include "Threads.h"
12 #include "Trace.h"
13 #include "RaiseAsync.h"
14 #include "SMP.h"
15 #include "Schedule.h"
16 #include "LdvProfile.h"
17 #include "Updates.h"
18 #include "STM.h"
19 #include "Sanity.h"
20 #include "Profiling.h"
21 #if defined(mingw32_HOST_OS)
22 #include "win32/IOManager.h"
23 #endif
24
25 static void raiseAsync (Capability *cap,
26                         StgTSO *tso,
27                         StgClosure *exception, 
28                         rtsBool stop_at_atomically,
29                         StgPtr stop_here);
30
31 static void removeFromQueues(Capability *cap, StgTSO *tso);
32
33 static void blockedThrowTo (StgTSO *source, StgTSO *target);
34
35 static void performBlockedException (Capability *cap, 
36                                      StgTSO *source, StgTSO *target);
37
38 /* -----------------------------------------------------------------------------
39    throwToSingleThreaded
40
41    This version of throwTo is safe to use if and only if one of the
42    following holds:
43    
44      - !THREADED_RTS
45
46      - all the other threads in the system are stopped (eg. during GC).
47
48      - we surely own the target TSO (eg. we just took it from the
49        run queue of the current capability, or we are running it).
50
51    It doesn't cater for blocking the source thread until the exception
52    has been raised.
53    -------------------------------------------------------------------------- */
54
55 void
56 throwToSingleThreaded(Capability *cap, StgTSO *tso, StgClosure *exception)
57 {
58     throwToSingleThreaded_(cap, tso, exception, rtsFalse, NULL);
59 }
60
61 void
62 throwToSingleThreaded_(Capability *cap, StgTSO *tso, StgClosure *exception, 
63                        rtsBool stop_at_atomically, StgPtr stop_here)
64 {
65     // Thread already dead?
66     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
67         return;
68     }
69
70     // Remove it from any blocking queues
71     removeFromQueues(cap,tso);
72
73     raiseAsync(cap, tso, exception, stop_at_atomically, stop_here);
74 }
75
76 void
77 suspendComputation(Capability *cap, StgTSO *tso, StgPtr stop_here)
78 {
79     // Thread already dead?
80     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
81         return;
82     }
83
84     // Remove it from any blocking queues
85     removeFromQueues(cap,tso);
86
87     raiseAsync(cap, tso, NULL, rtsFalse, stop_here);
88 }
89
90 /* -----------------------------------------------------------------------------
91    throwTo
92
93    This function may be used to throw an exception from one thread to
94    another, during the course of normal execution.  This is a tricky
95    task: the target thread might be running on another CPU, or it
96    may be blocked and could be woken up at any point by another CPU.
97    We have some delicate synchronisation to do.
98
99    There is a completely safe fallback scheme: it is always possible
100    to just block the source TSO on the target TSO's blocked_exceptions
101    queue.  This queue is locked using lockTSO()/unlockTSO().  It is
102    checked at regular intervals: before and after running a thread
103    (schedule() and threadPaused() respectively), and just before GC
104    (scheduleDoGC()).  Activating a thread on this queue should be done
105    using maybePerformBlockedException(): this is done in the context
106    of the target thread, so the exception can be raised eagerly.
107
108    This fallback scheme works even if the target thread is complete or
109    killed: scheduleDoGC() will discover the blocked thread before the
110    target is GC'd.
111
112    Blocking the source thread on the target thread's blocked_exception
113    queue is also employed when the target thread is currently blocking
114    exceptions (ie. inside Control.Exception.block).
115
116    We could use the safe fallback scheme exclusively, but that
117    wouldn't be ideal: most calls to throwTo would block immediately,
118    possibly until the next GC, which might require the deadlock
119    detection mechanism to kick in.  So we try to provide promptness
120    wherever possible.
121
122    We can promptly deliver the exception if the target thread is:
123
124      - runnable, on the same Capability as the source thread (because
125        we own the run queue and therefore the target thread).
126    
127      - blocked, and we can obtain exclusive access to it.  Obtaining
128        exclusive access to the thread depends on how it is blocked.
129
130    We must also be careful to not trip over threadStackOverflow(),
131    which might be moving the TSO to enlarge its stack.
132    lockTSO()/unlockTSO() are used here too.
133
134    Returns: 
135
136    THROWTO_SUCCESS    exception was raised, ok to continue
137
138    THROWTO_BLOCKED    exception was not raised; block the source
139                       thread then call throwToReleaseTarget() when
140                       the source thread is properly tidied away.
141
142    -------------------------------------------------------------------------- */
143
144 nat
145 throwTo (Capability *cap,       // the Capability we hold 
146          StgTSO *source,        // the TSO sending the exception
147          StgTSO *target,        // the TSO receiving the exception
148          StgClosure *exception, // the exception closure
149          /*[out]*/ void **out USED_IF_THREADS)
150 {
151     StgWord status;
152
153     // follow ThreadRelocated links in the target first
154     while (target->what_next == ThreadRelocated) {
155         target = target->link;
156         // No, it might be a WHITEHOLE:
157         // ASSERT(get_itbl(target)->type == TSO);
158     }
159
160     debugTrace(DEBUG_sched, "throwTo: from thread %lu to thread %lu",
161                (unsigned long)source->id, (unsigned long)target->id);
162
163 #ifdef DEBUG
164     if (traceClass(DEBUG_sched)) {
165         debugTraceBegin("throwTo: target");
166         printThreadStatus(target);
167         debugTraceEnd();
168     }
169 #endif
170
171     goto check_target;
172 retry:
173     debugTrace(DEBUG_sched, "throwTo: retrying...");
174
175 check_target:
176     // Thread already dead?
177     if (target->what_next == ThreadComplete 
178         || target->what_next == ThreadKilled) {
179         return THROWTO_SUCCESS;
180     }
181
182     status = target->why_blocked;
183     
184     switch (status) {
185     case NotBlocked:
186         /* if status==NotBlocked, and target->cap == cap, then
187            we own this TSO and can raise the exception.
188            
189            How do we establish this condition?  Very carefully.
190
191            Let 
192                P = (status == NotBlocked)
193                Q = (tso->cap == cap)
194                
195            Now, if P & Q are true, then the TSO is locked and owned by
196            this capability.  No other OS thread can steal it.
197
198            If P==0 and Q==1: the TSO is blocked, but attached to this
199            capabilty, and it can be stolen by another capability.
200            
201            If P==1 and Q==0: the TSO is runnable on another
202            capability.  At any time, the TSO may change from runnable
203            to blocked and vice versa, while it remains owned by
204            another capability.
205
206            Suppose we test like this:
207
208               p = P
209               q = Q
210               if (p && q) ...
211
212             this is defeated by another capability stealing a blocked
213             TSO from us to wake it up (Schedule.c:unblockOne()).  The
214             other thread is doing
215
216               Q = 0
217               P = 1
218
219             assuming arbitrary reordering, we could see this
220             interleaving:
221
222               start: P==0 && Q==1 
223               P = 1
224               p = P
225               q = Q
226               Q = 0
227               if (p && q) ...
228                
229             so we need a memory barrier:
230
231               p = P
232               mb()
233               q = Q
234               if (p && q) ...
235
236             this avoids the problematic case.  There are other cases
237             to consider, but this is the tricky one.
238
239             Note that we must be sure that unblockOne() does the
240             writes in the correct order: Q before P.  The memory
241             barrier ensures that if we have seen the write to P, we
242             have also seen the write to Q.
243         */
244     {
245         Capability *target_cap;
246
247         write_barrier();
248         target_cap = target->cap;
249         if (target_cap == cap && (target->flags & TSO_BLOCKEX) == 0) {
250             // It's on our run queue and not blocking exceptions
251             raiseAsync(cap, target, exception, rtsFalse, NULL);
252             return THROWTO_SUCCESS;
253         } else {
254             // Otherwise, just block on the blocked_exceptions queue
255             // of the target thread.  The queue will get looked at
256             // soon enough: it is checked before and after running a
257             // thread, and during GC.
258             lockTSO(target);
259
260             // Avoid race with threadStackOverflow, which may have
261             // just moved this TSO.
262             if (target->what_next == ThreadRelocated) {
263                 unlockTSO(target);
264                 target = target->link;
265                 goto retry;
266             }
267             blockedThrowTo(source,target);
268             *out = target;
269             return THROWTO_BLOCKED;
270         }
271     }
272
273     case BlockedOnMVar:
274     {
275         /*
276           To establish ownership of this TSO, we need to acquire a
277           lock on the MVar that it is blocked on.
278         */
279         StgMVar *mvar;
280         StgInfoTable *info USED_IF_THREADS;
281         
282         mvar = (StgMVar *)target->block_info.closure;
283
284         // ASSUMPTION: tso->block_info must always point to a
285         // closure.  In the threaded RTS it does.
286         switch (get_itbl(mvar)->type) {
287         case MVAR_CLEAN:
288         case MVAR_DIRTY:
289             break;
290         default:
291             goto retry;
292         }
293
294         info = lockClosure((StgClosure *)mvar);
295
296         if (target->what_next == ThreadRelocated) {
297             target = target->link;
298             unlockClosure((StgClosure *)mvar,info);
299             goto retry;
300         }
301         // we have the MVar, let's check whether the thread
302         // is still blocked on the same MVar.
303         if (target->why_blocked != BlockedOnMVar
304             || (StgMVar *)target->block_info.closure != mvar) {
305             unlockClosure((StgClosure *)mvar, info);
306             goto retry;
307         }
308
309         if ((target->flags & TSO_BLOCKEX) &&
310             ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
311             lockClosure((StgClosure *)target);
312             blockedThrowTo(source,target);
313             unlockClosure((StgClosure *)mvar, info);
314             *out = target;
315             return THROWTO_BLOCKED; // caller releases TSO
316         } else {
317             removeThreadFromMVarQueue(mvar, target);
318             raiseAsync(cap, target, exception, rtsFalse, NULL);
319             unblockOne(cap, target);
320             unlockClosure((StgClosure *)mvar, info);
321             return THROWTO_SUCCESS;
322         }
323     }
324
325     case BlockedOnBlackHole:
326     {
327         ACQUIRE_LOCK(&sched_mutex);
328         // double checking the status after the memory barrier:
329         if (target->why_blocked != BlockedOnBlackHole) {
330             RELEASE_LOCK(&sched_mutex);
331             goto retry;
332         }
333
334         if (target->flags & TSO_BLOCKEX) {
335             lockTSO(target);
336             blockedThrowTo(source,target);
337             RELEASE_LOCK(&sched_mutex);
338             *out = target;
339             return THROWTO_BLOCKED; // caller releases TSO
340         } else {
341             removeThreadFromQueue(&blackhole_queue, target);
342             raiseAsync(cap, target, exception, rtsFalse, NULL);
343             unblockOne(cap, target);
344             RELEASE_LOCK(&sched_mutex);
345             return THROWTO_SUCCESS;
346         }
347     }
348
349     case BlockedOnException:
350     {
351         StgTSO *target2;
352         StgInfoTable *info;
353
354         /*
355           To obtain exclusive access to a BlockedOnException thread,
356           we must call lockClosure() on the TSO on which it is blocked.
357           Since the TSO might change underneath our feet, after we
358           call lockClosure() we must check that 
359            
360              (a) the closure we locked is actually a TSO
361              (b) the original thread is still  BlockedOnException,
362              (c) the original thread is still blocked on the TSO we locked
363              and (d) the target thread has not been relocated.
364
365           We synchronise with threadStackOverflow() (which relocates
366           threads) using lockClosure()/unlockClosure().
367         */
368         target2 = target->block_info.tso;
369
370         info = lockClosure((StgClosure *)target2);
371         if (info != &stg_TSO_info) {
372             unlockClosure((StgClosure *)target2, info);
373             goto retry;
374         }
375         if (target->what_next == ThreadRelocated) {
376             target = target->link;
377             unlockTSO(target2);
378             goto retry;
379         }
380         if (target2->what_next == ThreadRelocated) {
381             target->block_info.tso = target2->link;
382             unlockTSO(target2);
383             goto retry;
384         }
385         if (target->why_blocked != BlockedOnException
386             || target->block_info.tso != target2) {
387             unlockTSO(target2);
388             goto retry;
389         }
390         
391         /* 
392            Now we have exclusive rights to the target TSO...
393
394            If it is blocking exceptions, add the source TSO to its
395            blocked_exceptions queue.  Otherwise, raise the exception.
396         */
397         if ((target->flags & TSO_BLOCKEX) &&
398             ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
399             lockTSO(target);
400             blockedThrowTo(source,target);
401             unlockTSO(target2);
402             *out = target;
403             return THROWTO_BLOCKED;
404         } else {
405             removeThreadFromQueue(&target2->blocked_exceptions, target);
406             raiseAsync(cap, target, exception, rtsFalse, NULL);
407             unblockOne(cap, target);
408             unlockTSO(target2);
409             return THROWTO_SUCCESS;
410         }
411     }   
412
413     case BlockedOnSTM:
414         lockTSO(target);
415         // Unblocking BlockedOnSTM threads requires the TSO to be
416         // locked; see STM.c:unpark_tso().
417         if (target->why_blocked != BlockedOnSTM) {
418             goto retry;
419         }
420         if ((target->flags & TSO_BLOCKEX) &&
421             ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
422             blockedThrowTo(source,target);
423             *out = target;
424             return THROWTO_BLOCKED;
425         } else {
426             raiseAsync(cap, target, exception, rtsFalse, NULL);
427             unblockOne(cap, target);
428             unlockTSO(target);
429             return THROWTO_SUCCESS;
430         }
431
432     case BlockedOnCCall:
433     case BlockedOnCCall_NoUnblockExc:
434         // I don't think it's possible to acquire ownership of a
435         // BlockedOnCCall thread.  We just assume that the target
436         // thread is blocking exceptions, and block on its
437         // blocked_exception queue.
438         lockTSO(target);
439         blockedThrowTo(source,target);
440         *out = target;
441         return THROWTO_BLOCKED;
442
443 #ifndef THREADEDED_RTS
444     case BlockedOnRead:
445     case BlockedOnWrite:
446     case BlockedOnDelay:
447 #if defined(mingw32_HOST_OS)
448     case BlockedOnDoProc:
449 #endif
450         if ((target->flags & TSO_BLOCKEX) &&
451             ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
452             blockedThrowTo(source,target);
453             return THROWTO_BLOCKED;
454         } else {
455             removeFromQueues(cap,target);
456             raiseAsync(cap, target, exception, rtsFalse, NULL);
457             return THROWTO_SUCCESS;
458         }
459 #endif
460
461     default:
462         barf("throwTo: unrecognised why_blocked value");
463     }
464     barf("throwTo");
465 }
466
467 // Block a TSO on another TSO's blocked_exceptions queue.
468 // Precondition: we hold an exclusive lock on the target TSO (this is
469 // complex to achieve as there's no single lock on a TSO; see
470 // throwTo()).
471 static void
472 blockedThrowTo (StgTSO *source, StgTSO *target)
473 {
474     debugTrace(DEBUG_sched, "throwTo: blocking on thread %lu", (unsigned long)target->id);
475     source->link = target->blocked_exceptions;
476     target->blocked_exceptions = source;
477     dirtyTSO(target); // we modified the blocked_exceptions queue
478     
479     source->block_info.tso = target;
480     write_barrier(); // throwTo_exception *must* be visible if BlockedOnException is.
481     source->why_blocked = BlockedOnException;
482 }
483
484
485 #ifdef THREADED_RTS
486 void
487 throwToReleaseTarget (void *tso)
488 {
489     unlockTSO((StgTSO *)tso);
490 }
491 #endif
492
493 /* -----------------------------------------------------------------------------
494    Waking up threads blocked in throwTo
495
496    There are two ways to do this: maybePerformBlockedException() will
497    perform the throwTo() for the thread at the head of the queue
498    immediately, and leave the other threads on the queue.
499    maybePerformBlockedException() also checks the TSO_BLOCKEX flag
500    before raising an exception.
501
502    awakenBlockedExceptionQueue() will wake up all the threads in the
503    queue, but not perform any throwTo() immediately.  This might be
504    more appropriate when the target thread is the one actually running
505    (see Exception.cmm).
506
507    Returns: non-zero if an exception was raised, zero otherwise.
508    -------------------------------------------------------------------------- */
509
510 int
511 maybePerformBlockedException (Capability *cap, StgTSO *tso)
512 {
513     StgTSO *source;
514     
515     if (tso->blocked_exceptions != END_TSO_QUEUE
516         && ((tso->flags & TSO_BLOCKEX) == 0
517             || ((tso->flags & TSO_INTERRUPTIBLE) && interruptible(tso)))) {
518
519         // Lock the TSO, this gives us exclusive access to the queue
520         lockTSO(tso);
521
522         // Check the queue again; it might have changed before we
523         // locked it.
524         if (tso->blocked_exceptions == END_TSO_QUEUE) {
525             unlockTSO(tso);
526             return 0;
527         }
528
529         // We unblock just the first thread on the queue, and perform
530         // its throw immediately.
531         source = tso->blocked_exceptions;
532         performBlockedException(cap, source, tso);
533         tso->blocked_exceptions = unblockOne_(cap, source, 
534                                               rtsFalse/*no migrate*/);
535         unlockTSO(tso);
536         return 1;
537     }
538     return 0;
539 }
540
541 void
542 awakenBlockedExceptionQueue (Capability *cap, StgTSO *tso)
543 {
544     if (tso->blocked_exceptions != END_TSO_QUEUE) {
545         lockTSO(tso);
546         awakenBlockedQueue(cap, tso->blocked_exceptions);
547         tso->blocked_exceptions = END_TSO_QUEUE;
548         unlockTSO(tso);
549     }
550 }    
551
552 static void
553 performBlockedException (Capability *cap, StgTSO *source, StgTSO *target)
554 {
555     StgClosure *exception;
556
557     ASSERT(source->why_blocked == BlockedOnException);
558     ASSERT(source->block_info.tso->id == target->id);
559     ASSERT(source->sp[0] == (StgWord)&stg_block_throwto_info);
560     ASSERT(((StgTSO *)source->sp[1])->id == target->id);
561     // check ids not pointers, because the thread might be relocated
562
563     exception = (StgClosure *)source->sp[2];
564     throwToSingleThreaded(cap, target, exception);
565     source->sp += 3;
566 }
567
568 /* -----------------------------------------------------------------------------
569    Remove a thread from blocking queues.
570
571    This is for use when we raise an exception in another thread, which
572    may be blocked.
573    This has nothing to do with the UnblockThread event in GranSim. -- HWL
574    -------------------------------------------------------------------------- */
575
576 #if defined(GRAN) || defined(PARALLEL_HASKELL)
577 /*
578   NB: only the type of the blocking queue is different in GranSim and GUM
579       the operations on the queue-elements are the same
580       long live polymorphism!
581
582   Locks: sched_mutex is held upon entry and exit.
583
584 */
585 static void
586 removeFromQueues(Capability *cap, StgTSO *tso)
587 {
588   StgBlockingQueueElement *t, **last;
589
590   switch (tso->why_blocked) {
591
592   case NotBlocked:
593     return;  /* not blocked */
594
595   case BlockedOnSTM:
596     // Be careful: nothing to do here!  We tell the scheduler that the thread
597     // is runnable and we leave it to the stack-walking code to abort the 
598     // transaction while unwinding the stack.  We should perhaps have a debugging
599     // test to make sure that this really happens and that the 'zombie' transaction
600     // does not get committed.
601     goto done;
602
603   case BlockedOnMVar:
604     ASSERT(get_itbl(tso->block_info.closure)->type == MVAR);
605     {
606       StgBlockingQueueElement *last_tso = END_BQ_QUEUE;
607       StgMVar *mvar = (StgMVar *)(tso->block_info.closure);
608
609       last = (StgBlockingQueueElement **)&mvar->head;
610       for (t = (StgBlockingQueueElement *)mvar->head; 
611            t != END_BQ_QUEUE; 
612            last = &t->link, last_tso = t, t = t->link) {
613         if (t == (StgBlockingQueueElement *)tso) {
614           *last = (StgBlockingQueueElement *)tso->link;
615           if (mvar->tail == tso) {
616             mvar->tail = (StgTSO *)last_tso;
617           }
618           goto done;
619         }
620       }
621       barf("removeFromQueues (MVAR): TSO not found");
622     }
623
624   case BlockedOnBlackHole:
625     ASSERT(get_itbl(tso->block_info.closure)->type == BLACKHOLE_BQ);
626     {
627       StgBlockingQueue *bq = (StgBlockingQueue *)(tso->block_info.closure);
628
629       last = &bq->blocking_queue;
630       for (t = bq->blocking_queue; 
631            t != END_BQ_QUEUE; 
632            last = &t->link, t = t->link) {
633         if (t == (StgBlockingQueueElement *)tso) {
634           *last = (StgBlockingQueueElement *)tso->link;
635           goto done;
636         }
637       }
638       barf("removeFromQueues (BLACKHOLE): TSO not found");
639     }
640
641   case BlockedOnException:
642     {
643       StgTSO *target  = tso->block_info.tso;
644
645       ASSERT(get_itbl(target)->type == TSO);
646
647       while (target->what_next == ThreadRelocated) {
648           target = target2->link;
649           ASSERT(get_itbl(target)->type == TSO);
650       }
651
652       last = (StgBlockingQueueElement **)&target->blocked_exceptions;
653       for (t = (StgBlockingQueueElement *)target->blocked_exceptions; 
654            t != END_BQ_QUEUE; 
655            last = &t->link, t = t->link) {
656         ASSERT(get_itbl(t)->type == TSO);
657         if (t == (StgBlockingQueueElement *)tso) {
658           *last = (StgBlockingQueueElement *)tso->link;
659           goto done;
660         }
661       }
662       barf("removeFromQueues (Exception): TSO not found");
663     }
664
665   case BlockedOnRead:
666   case BlockedOnWrite:
667 #if defined(mingw32_HOST_OS)
668   case BlockedOnDoProc:
669 #endif
670     {
671       /* take TSO off blocked_queue */
672       StgBlockingQueueElement *prev = NULL;
673       for (t = (StgBlockingQueueElement *)blocked_queue_hd; t != END_BQ_QUEUE; 
674            prev = t, t = t->link) {
675         if (t == (StgBlockingQueueElement *)tso) {
676           if (prev == NULL) {
677             blocked_queue_hd = (StgTSO *)t->link;
678             if ((StgBlockingQueueElement *)blocked_queue_tl == t) {
679               blocked_queue_tl = END_TSO_QUEUE;
680             }
681           } else {
682             prev->link = t->link;
683             if ((StgBlockingQueueElement *)blocked_queue_tl == t) {
684               blocked_queue_tl = (StgTSO *)prev;
685             }
686           }
687 #if defined(mingw32_HOST_OS)
688           /* (Cooperatively) signal that the worker thread should abort
689            * the request.
690            */
691           abandonWorkRequest(tso->block_info.async_result->reqID);
692 #endif
693           goto done;
694         }
695       }
696       barf("removeFromQueues (I/O): TSO not found");
697     }
698
699   case BlockedOnDelay:
700     {
701       /* take TSO off sleeping_queue */
702       StgBlockingQueueElement *prev = NULL;
703       for (t = (StgBlockingQueueElement *)sleeping_queue; t != END_BQ_QUEUE; 
704            prev = t, t = t->link) {
705         if (t == (StgBlockingQueueElement *)tso) {
706           if (prev == NULL) {
707             sleeping_queue = (StgTSO *)t->link;
708           } else {
709             prev->link = t->link;
710           }
711           goto done;
712         }
713       }
714       barf("removeFromQueues (delay): TSO not found");
715     }
716
717   default:
718     barf("removeFromQueues: %d", tso->why_blocked);
719   }
720
721  done:
722   tso->link = END_TSO_QUEUE;
723   tso->why_blocked = NotBlocked;
724   tso->block_info.closure = NULL;
725   pushOnRunQueue(cap,tso);
726 }
727 #else
728 static void
729 removeFromQueues(Capability *cap, StgTSO *tso)
730 {
731   switch (tso->why_blocked) {
732
733   case NotBlocked:
734       return;
735
736   case BlockedOnSTM:
737     // Be careful: nothing to do here!  We tell the scheduler that the
738     // thread is runnable and we leave it to the stack-walking code to
739     // abort the transaction while unwinding the stack.  We should
740     // perhaps have a debugging test to make sure that this really
741     // happens and that the 'zombie' transaction does not get
742     // committed.
743     goto done;
744
745   case BlockedOnMVar:
746       removeThreadFromMVarQueue((StgMVar *)tso->block_info.closure, tso);
747       goto done;
748
749   case BlockedOnBlackHole:
750       removeThreadFromQueue(&blackhole_queue, tso);
751       goto done;
752
753   case BlockedOnException:
754     {
755       StgTSO *target  = tso->block_info.tso;
756
757       // NO: when called by threadPaused(), we probably have this
758       // TSO already locked (WHITEHOLEd) because we just placed
759       // ourselves on its queue.
760       // ASSERT(get_itbl(target)->type == TSO);
761
762       while (target->what_next == ThreadRelocated) {
763           target = target->link;
764       }
765       
766       removeThreadFromQueue(&target->blocked_exceptions, tso);
767       goto done;
768     }
769
770 #if !defined(THREADED_RTS)
771   case BlockedOnRead:
772   case BlockedOnWrite:
773 #if defined(mingw32_HOST_OS)
774   case BlockedOnDoProc:
775 #endif
776       removeThreadFromDeQueue(&blocked_queue_hd, &blocked_queue_tl, tso);
777 #if defined(mingw32_HOST_OS)
778       /* (Cooperatively) signal that the worker thread should abort
779        * the request.
780        */
781       abandonWorkRequest(tso->block_info.async_result->reqID);
782 #endif
783       goto done;
784
785   case BlockedOnDelay:
786         removeThreadFromQueue(&sleeping_queue, tso);
787         goto done;
788 #endif
789
790   default:
791       barf("removeFromQueues: %d", tso->why_blocked);
792   }
793
794  done:
795   tso->link = END_TSO_QUEUE;
796   tso->why_blocked = NotBlocked;
797   tso->block_info.closure = NULL;
798   appendToRunQueue(cap,tso);
799
800   // We might have just migrated this TSO to our Capability:
801   if (tso->bound) {
802       tso->bound->cap = cap;
803   }
804   tso->cap = cap;
805 }
806 #endif
807
808 /* -----------------------------------------------------------------------------
809  * raiseAsync()
810  *
811  * The following function implements the magic for raising an
812  * asynchronous exception in an existing thread.
813  *
814  * We first remove the thread from any queue on which it might be
815  * blocked.  The possible blockages are MVARs and BLACKHOLE_BQs.
816  *
817  * We strip the stack down to the innermost CATCH_FRAME, building
818  * thunks in the heap for all the active computations, so they can 
819  * be restarted if necessary.  When we reach a CATCH_FRAME, we build
820  * an application of the handler to the exception, and push it on
821  * the top of the stack.
822  * 
823  * How exactly do we save all the active computations?  We create an
824  * AP_STACK for every UpdateFrame on the stack.  Entering one of these
825  * AP_STACKs pushes everything from the corresponding update frame
826  * upwards onto the stack.  (Actually, it pushes everything up to the
827  * next update frame plus a pointer to the next AP_STACK object.
828  * Entering the next AP_STACK object pushes more onto the stack until we
829  * reach the last AP_STACK object - at which point the stack should look
830  * exactly as it did when we killed the TSO and we can continue
831  * execution by entering the closure on top of the stack.
832  *
833  * We can also kill a thread entirely - this happens if either (a) the 
834  * exception passed to raiseAsync is NULL, or (b) there's no
835  * CATCH_FRAME on the stack.  In either case, we strip the entire
836  * stack and replace the thread with a zombie.
837  *
838  * ToDo: in THREADED_RTS mode, this function is only safe if either
839  * (a) we hold all the Capabilities (eg. in GC, or if there is only
840  * one Capability), or (b) we own the Capability that the TSO is
841  * currently blocked on or on the run queue of.
842  *
843  * -------------------------------------------------------------------------- */
844
845 static void
846 raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, 
847            rtsBool stop_at_atomically, StgPtr stop_here)
848 {
849     StgRetInfoTable *info;
850     StgPtr sp, frame;
851     nat i;
852
853     debugTrace(DEBUG_sched,
854                "raising exception in thread %ld.", (long)tso->id);
855     
856 #if defined(PROFILING)
857     /* 
858      * Debugging tool: on raising an  exception, show where we are.
859      * See also Exception.cmm:raisezh_fast.
860      * This wasn't done for asynchronous exceptions originally; see #1450 
861      */
862     if (RtsFlags.ProfFlags.showCCSOnException)
863     {
864         fprintCCS_stderr(tso->prof.CCCS);
865     }
866 #endif
867
868     // mark it dirty; we're about to change its stack.
869     dirtyTSO(tso);
870
871     sp = tso->sp;
872     
873     // ASSUMES: the thread is not already complete or dead.  Upper
874     // layers should deal with that.
875     ASSERT(tso->what_next != ThreadComplete && tso->what_next != ThreadKilled);
876
877     // The stack freezing code assumes there's a closure pointer on
878     // the top of the stack, so we have to arrange that this is the case...
879     //
880     if (sp[0] == (W_)&stg_enter_info) {
881         sp++;
882     } else {
883         sp--;
884         sp[0] = (W_)&stg_dummy_ret_closure;
885     }
886
887     frame = sp + 1;
888     while (stop_here == NULL || frame < stop_here) {
889
890         // 1. Let the top of the stack be the "current closure"
891         //
892         // 2. Walk up the stack until we find either an UPDATE_FRAME or a
893         // CATCH_FRAME.
894         //
895         // 3. If it's an UPDATE_FRAME, then make an AP_STACK containing the
896         // current closure applied to the chunk of stack up to (but not
897         // including) the update frame.  This closure becomes the "current
898         // closure".  Go back to step 2.
899         //
900         // 4. If it's a CATCH_FRAME, then leave the exception handler on
901         // top of the stack applied to the exception.
902         // 
903         // 5. If it's a STOP_FRAME, then kill the thread.
904         // 
905         // NB: if we pass an ATOMICALLY_FRAME then abort the associated 
906         // transaction
907        
908         info = get_ret_itbl((StgClosure *)frame);
909
910         switch (info->i.type) {
911
912         case UPDATE_FRAME:
913         {
914             StgAP_STACK * ap;
915             nat words;
916             
917             // First build an AP_STACK consisting of the stack chunk above the
918             // current update frame, with the top word on the stack as the
919             // fun field.
920             //
921             words = frame - sp - 1;
922             ap = (StgAP_STACK *)allocateLocal(cap,AP_STACK_sizeW(words));
923             
924             ap->size = words;
925             ap->fun  = (StgClosure *)sp[0];
926             sp++;
927             for(i=0; i < (nat)words; ++i) {
928                 ap->payload[i] = (StgClosure *)*sp++;
929             }
930             
931             SET_HDR(ap,&stg_AP_STACK_info,
932                     ((StgClosure *)frame)->header.prof.ccs /* ToDo */); 
933             TICK_ALLOC_UP_THK(words+1,0);
934             
935             //IF_DEBUG(scheduler,
936             //       debugBelch("sched: Updating ");
937             //       printPtr((P_)((StgUpdateFrame *)frame)->updatee); 
938             //       debugBelch(" with ");
939             //       printObj((StgClosure *)ap);
940             //  );
941
942             // Replace the updatee with an indirection
943             //
944             // Warning: if we're in a loop, more than one update frame on
945             // the stack may point to the same object.  Be careful not to
946             // overwrite an IND_OLDGEN in this case, because we'll screw
947             // up the mutable lists.  To be on the safe side, don't
948             // overwrite any kind of indirection at all.  See also
949             // threadSqueezeStack in GC.c, where we have to make a similar
950             // check.
951             //
952             if (!closure_IND(((StgUpdateFrame *)frame)->updatee)) {
953                 // revert the black hole
954                 UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,
955                                (StgClosure *)ap);
956             }
957             sp += sizeofW(StgUpdateFrame) - 1;
958             sp[0] = (W_)ap; // push onto stack
959             frame = sp + 1;
960             continue; //no need to bump frame
961         }
962
963         case STOP_FRAME:
964         {
965             // We've stripped the entire stack, the thread is now dead.
966             tso->what_next = ThreadKilled;
967             tso->sp = frame + sizeofW(StgStopFrame);
968             return;
969         }
970
971         case CATCH_FRAME:
972             // If we find a CATCH_FRAME, and we've got an exception to raise,
973             // then build the THUNK raise(exception), and leave it on
974             // top of the CATCH_FRAME ready to enter.
975             //
976         {
977 #ifdef PROFILING
978             StgCatchFrame *cf = (StgCatchFrame *)frame;
979 #endif
980             StgThunk *raise;
981             
982             if (exception == NULL) break;
983
984             // we've got an exception to raise, so let's pass it to the
985             // handler in this frame.
986             //
987             raise = (StgThunk *)allocateLocal(cap,sizeofW(StgThunk)+1);
988             TICK_ALLOC_SE_THK(1,0);
989             SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
990             raise->payload[0] = exception;
991             
992             // throw away the stack from Sp up to the CATCH_FRAME.
993             //
994             sp = frame - 1;
995             
996             /* Ensure that async excpetions are blocked now, so we don't get
997              * a surprise exception before we get around to executing the
998              * handler.
999              */
1000             tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
1001
1002             /* Put the newly-built THUNK on top of the stack, ready to execute
1003              * when the thread restarts.
1004              */
1005             sp[0] = (W_)raise;
1006             sp[-1] = (W_)&stg_enter_info;
1007             tso->sp = sp-1;
1008             tso->what_next = ThreadRunGHC;
1009             IF_DEBUG(sanity, checkTSO(tso));
1010             return;
1011         }
1012             
1013         case ATOMICALLY_FRAME:
1014             if (stop_at_atomically) {
1015                 ASSERT(stmGetEnclosingTRec(tso->trec) == NO_TREC);
1016                 stmCondemnTransaction(cap, tso -> trec);
1017 #ifdef REG_R1
1018                 tso->sp = frame;
1019 #else
1020                 // R1 is not a register: the return convention for IO in
1021                 // this case puts the return value on the stack, so we
1022                 // need to set up the stack to return to the atomically
1023                 // frame properly...
1024                 tso->sp = frame - 2;
1025                 tso->sp[1] = (StgWord) &stg_NO_FINALIZER_closure; // why not?
1026                 tso->sp[0] = (StgWord) &stg_ut_1_0_unreg_info;
1027 #endif
1028                 tso->what_next = ThreadRunGHC;
1029                 return;
1030             }
1031             // Not stop_at_atomically... fall through and abort the
1032             // transaction.
1033             
1034         case CATCH_RETRY_FRAME:
1035             // IF we find an ATOMICALLY_FRAME then we abort the
1036             // current transaction and propagate the exception.  In
1037             // this case (unlike ordinary exceptions) we do not care
1038             // whether the transaction is valid or not because its
1039             // possible validity cannot have caused the exception
1040             // and will not be visible after the abort.
1041
1042                 {
1043             StgTRecHeader *trec = tso -> trec;
1044             StgTRecHeader *outer = stmGetEnclosingTRec(trec);
1045             debugTrace(DEBUG_stm, 
1046                        "found atomically block delivering async exception");
1047             stmAbortTransaction(cap, trec);
1048             stmFreeAbortedTRec(cap, trec);
1049             tso -> trec = outer;
1050             break;
1051             };
1052             
1053         default:
1054             break;
1055         }
1056
1057         // move on to the next stack frame
1058         frame += stack_frame_sizeW((StgClosure *)frame);
1059     }
1060
1061     // if we got here, then we stopped at stop_here
1062     ASSERT(stop_here != NULL);
1063 }
1064
1065