Implement atomicReadMVar, fixing #4001.
[ghc.git] / rts / PrimOps.cmm
1 /* -*- tab-width: 8 -*- */
2 /* -----------------------------------------------------------------------------
3  *
4  * (c) The GHC Team, 1998-2012
5  *
6  * Out-of-line primitive operations
7  *
8  * This file contains the implementations of all the primitive
9  * operations ("primops") which are not expanded inline.  See
10  * ghc/compiler/prelude/primops.txt.pp for a list of all the primops;
11  * this file contains code for most of those with the attribute
12  * out_of_line=True.
13  *
14  * Entry convention: the entry convention for a primop is the
15  * NativeNodeCall convention, and the return convention is
16  * NativeReturn.  (see compiler/cmm/CmmCallConv.hs)
17  *
18  * This file is written in a subset of C--, extended with various
19  * features specific to GHC.  It is compiled by GHC directly.  For the
20  * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
21  *
22  * ---------------------------------------------------------------------------*/
23
24 #include "Cmm.h"
25
26 #ifdef __PIC__
27 import pthread_mutex_lock;
28 import pthread_mutex_unlock;
29 #endif
30 import base_ControlziExceptionziBase_nestedAtomically_closure;
31 import EnterCriticalSection;
32 import LeaveCriticalSection;
33 import ghczmprim_GHCziTypes_False_closure;
34 #if defined(USE_MINIINTERPRETER) || !defined(mingw32_HOST_OS)
35 import sm_mutex;
36 #endif
37
38 /*-----------------------------------------------------------------------------
39   Array Primitives
40
41   Basically just new*Array - the others are all inline macros.
42
43   The slow entry point is for returning from a heap check, the saved
44   size argument must be re-loaded from the stack.
45   -------------------------------------------------------------------------- */
46
47 /* for objects that are *less* than the size of a word, make sure we
48  * round up to the nearest word for the size of the array.
49  */
50
51 stg_newByteArrayzh ( W_ n )
52 {
53     W_ words, payload_words;
54     gcptr p;
55
56     MAYBE_GC_N(stg_newByteArrayzh, n);
57
58     payload_words = ROUNDUP_BYTES_TO_WDS(n);
59     words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
60     ("ptr" p) = ccall allocate(MyCapability() "ptr",words);
61     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
62     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
63     StgArrWords_bytes(p) = n;
64     return (p);
65 }
66
67 #define BA_ALIGN 16
68 #define BA_MASK  (BA_ALIGN-1)
69
70 stg_newPinnedByteArrayzh ( W_ n )
71 {
72     W_ words, bytes, payload_words;
73     gcptr p;
74
75     MAYBE_GC_N(stg_newPinnedByteArrayzh, n);
76
77     bytes = n;
78     /* payload_words is what we will tell the profiler we had to allocate */
79     payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
80     /* When we actually allocate memory, we need to allow space for the
81        header: */
82     bytes = bytes + SIZEOF_StgArrWords;
83     /* And we want to align to BA_ALIGN bytes, so we need to allow space
84        to shift up to BA_ALIGN - 1 bytes: */
85     bytes = bytes + BA_ALIGN - 1;
86     /* Now we convert to a number of words: */
87     words = ROUNDUP_BYTES_TO_WDS(bytes);
88
89     ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
90     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
91
92     /* Now we need to move p forward so that the payload is aligned
93        to BA_ALIGN bytes: */
94     p = p + ((-p - SIZEOF_StgArrWords) & BA_MASK);
95
96     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
97     StgArrWords_bytes(p) = n;
98     return (p);
99 }
100
101 stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
102 {
103     W_ words, bytes, payload_words;
104     gcptr p;
105
106     again: MAYBE_GC(again);
107
108     /* we always supply at least word-aligned memory, so there's no
109        need to allow extra space for alignment if the requirement is less
110        than a word.  This also prevents mischief with alignment == 0. */
111     if (alignment <= SIZEOF_W) { alignment = 1; }
112
113     bytes = n;
114
115     /* payload_words is what we will tell the profiler we had to allocate */
116     payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
117
118     /* When we actually allocate memory, we need to allow space for the
119        header: */
120     bytes = bytes + SIZEOF_StgArrWords;
121     /* And we want to align to <alignment> bytes, so we need to allow space
122        to shift up to <alignment - 1> bytes: */
123     bytes = bytes + alignment - 1;
124     /* Now we convert to a number of words: */
125     words = ROUNDUP_BYTES_TO_WDS(bytes);
126
127     ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
128     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
129
130     /* Now we need to move p forward so that the payload is aligned
131        to <alignment> bytes. Note that we are assuming that
132        <alignment> is a power of 2, which is technically not guaranteed */
133     p = p + ((-p - SIZEOF_StgArrWords) & (alignment - 1));
134
135     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
136     StgArrWords_bytes(p) = n;
137     return (p);
138 }
139
140 stg_newArrayzh ( W_ n /* words */, gcptr init )
141 {
142     W_ words, size;
143     gcptr p, arr;
144
145     again: MAYBE_GC(again);
146
147     // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words
148     // in the array, making sure we round up, and then rounding up to a whole
149     // number of words.
150     size = n + mutArrPtrsCardWords(n);
151     words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;
152     ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
153     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
154
155     SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
156     StgMutArrPtrs_ptrs(arr) = n;
157     StgMutArrPtrs_size(arr) = size;
158
159     // Initialise all elements of the the array with the value in R2
160     p = arr + SIZEOF_StgMutArrPtrs;
161   for:
162     if (p < arr + WDS(words)) {
163         W_[p] = init;
164         p = p + WDS(1);
165         goto for;
166     }
167     // Initialise the mark bits with 0
168   for2:
169     if (p < arr + WDS(size)) {
170         W_[p] = 0;
171         p = p + WDS(1);
172         goto for2;
173     }
174
175     return (arr);
176 }
177
178 stg_unsafeThawArrayzh ( gcptr arr )
179 {
180   // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
181   //
182   // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
183   // normally doesn't.  However, when we freeze a MUT_ARR_PTRS, we leave
184   // it on the mutable list for the GC to remove (removing something from
185   // the mutable list is not easy).
186   //
187   // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
188   // when we freeze it we set the info ptr to be MUT_ARR_PTRS_FROZEN0
189   // to indicate that it is still on the mutable list.
190   //
191   // So, when we thaw a MUT_ARR_PTRS_FROZEN, we must cope with two cases:
192   // either it is on a mut_list, or it isn't.  We adopt the convention that
193   // the closure type is MUT_ARR_PTRS_FROZEN0 if it is on the mutable list,
194   // and MUT_ARR_PTRS_FROZEN otherwise.  In fact it wouldn't matter if
195   // we put it on the mutable list more than once, but it would get scavenged
196   // multiple times during GC, which would be unnecessarily slow.
197   //
198   if (StgHeader_info(arr) != stg_MUT_ARR_PTRS_FROZEN0_info) {
199         SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
200         recordMutable(arr);
201         // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
202         return (arr);
203   } else {
204         SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
205         return (arr);
206   }
207 }
208
209 stg_newArrayArrayzh ( W_ n /* words */ )
210 {
211     W_ words, size;
212     gcptr p, arr;
213
214     MAYBE_GC_N(stg_newArrayArrayzh, n);
215
216     // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words
217     // in the array, making sure we round up, and then rounding up to a whole
218     // number of words.
219     size = n + mutArrPtrsCardWords(n);
220     words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;
221     ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
222     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
223
224     SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]);
225     StgMutArrPtrs_ptrs(arr) = n;
226     StgMutArrPtrs_size(arr) = size;
227
228     // Initialise all elements of the array with a pointer to the new array
229     p = arr + SIZEOF_StgMutArrPtrs;
230   for:
231     if (p < arr + WDS(words)) {
232         W_[p] = arr;
233         p = p + WDS(1);
234         goto for;
235     }
236     // Initialise the mark bits with 0
237   for2:
238     if (p < arr + WDS(size)) {
239         W_[p] = 0;
240         p = p + WDS(1);
241         goto for2;
242     }
243
244     return (arr);
245 }
246
247
248 /* -----------------------------------------------------------------------------
249    MutVar primitives
250    -------------------------------------------------------------------------- */
251
252 stg_newMutVarzh ( gcptr init )
253 {
254     W_ mv;
255
256     ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
257
258     mv = Hp - SIZEOF_StgMutVar + WDS(1);
259     SET_HDR(mv,stg_MUT_VAR_DIRTY_info,CCCS);
260     StgMutVar_var(mv) = init;
261
262     return (mv);
263 }
264
265 stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
266  /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, a #) */
267 {
268     gcptr h;
269
270     (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var,
271                           old, new);
272     if (h != old) {
273         return (1,h);
274     } else {
275         if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
276            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
277         }
278         return (0,h);
279     }
280 }
281
282 stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
283 {
284     W_ z, x, y, r, h;
285
286     /* If x is the current contents of the MutVar#, then
287        We want to make the new contents point to
288
289          (sel_0 (f x))
290
291        and the return value is
292
293          (sel_1 (f x))
294
295         obviously we can share (f x).
296
297          z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
298          y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
299          r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
300     */
301
302 #if MIN_UPD_SIZE > 1
303 #define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
304 #define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
305 #else
306 #define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
307 #define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
308 #endif
309
310 #if MIN_UPD_SIZE > 2
311 #define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
312 #define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
313 #else
314 #define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
315 #define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
316 #endif
317
318 #define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)
319
320    HP_CHK_GEN_TICKY(SIZE);
321
322    TICK_ALLOC_THUNK_2();
323    CCCS_ALLOC(THUNK_2_SIZE);
324    z = Hp - THUNK_2_SIZE + WDS(1);
325    SET_HDR(z, stg_ap_2_upd_info, CCCS);
326    LDV_RECORD_CREATE(z);
327    StgThunk_payload(z,0) = f;
328
329    TICK_ALLOC_THUNK_1();
330    CCCS_ALLOC(THUNK_1_SIZE);
331    y = z - THUNK_1_SIZE;
332    SET_HDR(y, stg_sel_0_upd_info, CCCS);
333    LDV_RECORD_CREATE(y);
334    StgThunk_payload(y,0) = z;
335
336    TICK_ALLOC_THUNK_1();
337    CCCS_ALLOC(THUNK_1_SIZE);
338    r = y - THUNK_1_SIZE;
339    SET_HDR(r, stg_sel_1_upd_info, CCCS);
340    LDV_RECORD_CREATE(r);
341    StgThunk_payload(r,0) = z;
342
343  retry:
344    x = StgMutVar_var(mv);
345    StgThunk_payload(z,1) = x;
346 #ifdef THREADED_RTS
347    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
348    if (h != x) { goto retry; }
349 #else
350    StgMutVar_var(mv) = y;
351 #endif
352
353    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
354      ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
355    }
356
357    return (r);
358 }
359
360 /* -----------------------------------------------------------------------------
361    Weak Pointer Primitives
362    -------------------------------------------------------------------------- */
363
364 STRING(stg_weak_msg,"New weak pointer at %p\n")
365
366 stg_mkWeakzh ( gcptr key,
367                gcptr value,
368                gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
369 {
370   gcptr w;
371
372   ALLOC_PRIM (SIZEOF_StgWeak)
373
374   w = Hp - SIZEOF_StgWeak + WDS(1);
375   SET_HDR(w, stg_WEAK_info, CCCS);
376
377   StgWeak_key(w)         = key;
378   StgWeak_value(w)       = value;
379   StgWeak_finalizer(w)   = finalizer;
380   StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
381
382   ACQUIRE_LOCK(sm_mutex);
383   StgWeak_link(w) = generation_weak_ptr_list(W_[g0]);
384   generation_weak_ptr_list(W_[g0]) = w;
385   RELEASE_LOCK(sm_mutex);
386
387   IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
388
389   return (w);
390 }
391
392 stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
393 {
394   jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
395 }
396
397 STRING(stg_cfinalizer_msg,"Adding a finalizer to %p\n")
398
399 stg_addCFinalizzerToWeakzh ( W_ fptr,   // finalizer
400                              W_ ptr,
401                              W_ flag,   // has environment (0 or 1)
402                              W_ eptr,
403                              gcptr w )
404 {
405   W_ c, info;
406
407   ("ptr" info) = ccall lockClosure(w "ptr");
408
409   if (info == stg_DEAD_WEAK_info) {
410     // Already dead.
411     unlockClosure(w, info);
412     return (0);
413   }
414
415   ALLOC_PRIM (SIZEOF_StgCFinalizerList)
416
417   c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
418   SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
419
420   StgCFinalizerList_fptr(c) = fptr;
421   StgCFinalizerList_ptr(c) = ptr;
422   StgCFinalizerList_eptr(c) = eptr;
423   StgCFinalizerList_flag(c) = flag;
424
425   StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
426   StgWeak_cfinalizers(w) = c;
427
428   unlockClosure(w, info);
429
430   recordMutable(w);
431
432   IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
433
434   return (1);
435 }
436
437 stg_finalizzeWeakzh ( gcptr w )
438 {
439   gcptr f, list;
440   W_ info;
441
442   ("ptr" info) = ccall lockClosure(w "ptr");
443
444   // already dead?
445   if (info == stg_DEAD_WEAK_info) {
446       unlockClosure(w, info);
447       return (0,stg_NO_FINALIZER_closure);
448   }
449
450   f    = StgWeak_finalizer(w);
451   list = StgWeak_cfinalizers(w);
452
453   // kill it
454 #ifdef PROFILING
455   // @LDV profiling
456   // A weak pointer is inherently used, so we do not need to call
457   // LDV_recordDead_FILL_SLOP_DYNAMIC():
458   //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
459   // or, LDV_recordDead():
460   //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
461   // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
462   // large as weak pointers, so there is no need to fill the slop, either.
463   // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
464 #endif
465
466   //
467   // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
468   //
469   unlockClosure(w, stg_DEAD_WEAK_info);
470
471   LDV_RECORD_CREATE(w);
472
473   if (list != stg_NO_FINALIZER_closure) {
474     ccall runCFinalizers(list);
475   }
476
477   /* return the finalizer */
478   if (f == stg_NO_FINALIZER_closure) {
479       return (0,stg_NO_FINALIZER_closure);
480   } else {
481       return (1,f);
482   }
483 }
484
485 stg_deRefWeakzh ( gcptr w )
486 {
487   W_ code, info;
488   gcptr val;
489
490   info = GET_INFO(w);
491
492   if (info == stg_WHITEHOLE_info) {
493     // w is locked by another thread. Now it's not immediately clear if w is
494     // alive or not. We use lockClosure to wait for the info pointer to become
495     // something other than stg_WHITEHOLE_info.
496
497     ("ptr" info) = ccall lockClosure(w "ptr");
498     unlockClosure(w, info);
499   }
500
501   if (info == stg_WEAK_info) {
502     code = 1;
503     val = StgWeak_value(w);
504   } else {
505     code = 0;
506     val = w;
507   }
508   return (code,val);
509 }
510
511 /* -----------------------------------------------------------------------------
512    Floating point operations.
513    -------------------------------------------------------------------------- */
514
515 stg_decodeFloatzuIntzh ( F_ arg )
516 {
517     W_ p;
518     W_ mp_tmp1;
519     W_ mp_tmp_w;
520
521     STK_CHK_GEN_N (WDS(2));
522
523     mp_tmp1  = Sp - WDS(1);
524     mp_tmp_w = Sp - WDS(2);
525
526     /* Perform the operation */
527     ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
528
529     /* returns: (Int# (mantissa), Int# (exponent)) */
530     return (W_[mp_tmp1], W_[mp_tmp_w]);
531 }
532
533 stg_decodeDoublezu2Intzh ( D_ arg )
534 {
535     W_ p;
536     W_ mp_tmp1;
537     W_ mp_tmp2;
538     W_ mp_result1;
539     W_ mp_result2;
540
541     STK_CHK_GEN_N (WDS(4));
542
543     mp_tmp1    = Sp - WDS(1);
544     mp_tmp2    = Sp - WDS(2);
545     mp_result1 = Sp - WDS(3);
546     mp_result2 = Sp - WDS(4);
547
548     /* Perform the operation */
549     ccall __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
550                                     mp_result1 "ptr", mp_result2 "ptr",
551                                     arg);
552
553     /* returns:
554        (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
555     return (W_[mp_tmp1], W_[mp_tmp2], W_[mp_result1], W_[mp_result2]);
556 }
557
558 /* -----------------------------------------------------------------------------
559  * Concurrency primitives
560  * -------------------------------------------------------------------------- */
561
562 stg_forkzh ( gcptr closure )
563 {
564   MAYBE_GC_P(stg_forkzh, closure);
565
566   gcptr threadid;
567
568   ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
569                                 RtsFlags_GcFlags_initialStkSize(RtsFlags),
570                                 closure "ptr");
571
572   /* start blocked if the current thread is blocked */
573   StgTSO_flags(threadid) = %lobits16(
574      TO_W_(StgTSO_flags(threadid)) |
575      TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
576
577   ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
578
579   // context switch soon, but not immediately: we don't want every
580   // forkIO to force a context-switch.
581   Capability_context_switch(MyCapability()) = 1 :: CInt;
582
583   return (threadid);
584 }
585
586 stg_forkOnzh ( W_ cpu, gcptr closure )
587 {
588 again: MAYBE_GC(again);
589
590   gcptr threadid;
591
592   ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
593                                 RtsFlags_GcFlags_initialStkSize(RtsFlags),
594                                 closure "ptr");
595
596   /* start blocked if the current thread is blocked */
597   StgTSO_flags(threadid) = %lobits16(
598      TO_W_(StgTSO_flags(threadid)) |
599      TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
600
601   ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr");
602
603   // context switch soon, but not immediately: we don't want every
604   // forkIO to force a context-switch.
605   Capability_context_switch(MyCapability()) = 1 :: CInt;
606
607   return (threadid);
608 }
609
610 stg_yieldzh ()
611 {
612   // when we yield to the scheduler, we have to tell it to put the
613   // current thread to the back of the queue by setting the
614   // context_switch flag.  If we don't do this, it will run the same
615   // thread again.
616   Capability_context_switch(MyCapability()) = 1 :: CInt;
617   jump stg_yield_noregs();
618 }
619
620 stg_myThreadIdzh ()
621 {
622   return (CurrentTSO);
623 }
624
625 stg_labelThreadzh ( gcptr threadid, W_ addr )
626 {
627 #if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
628   ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
629 #endif
630   return ();
631 }
632
633 stg_isCurrentThreadBoundzh (/* no args */)
634 {
635   W_ r;
636   (r) = ccall isThreadBound(CurrentTSO);
637   return (r);
638 }
639
640 stg_threadStatuszh ( gcptr tso )
641 {
642     W_ why_blocked;
643     W_ what_next;
644     W_ ret, cap, locked;
645
646     what_next   = TO_W_(StgTSO_what_next(tso));
647     why_blocked = TO_W_(StgTSO_why_blocked(tso));
648     // Note: these two reads are not atomic, so they might end up
649     // being inconsistent.  It doesn't matter, since we
650     // only return one or the other.  If we wanted to return the
651     // contents of block_info too, then we'd have to do some synchronisation.
652
653     if (what_next == ThreadComplete) {
654         ret = 16;  // NB. magic, matches up with GHC.Conc.threadStatus
655     } else {
656         if (what_next == ThreadKilled) {
657             ret = 17;
658         } else {
659             ret = why_blocked;
660         }
661     }
662
663     cap = TO_W_(Capability_no(StgTSO_cap(tso)));
664
665     if ((TO_W_(StgTSO_flags(tso)) & TSO_LOCKED) != 0) {
666         locked = 1;
667     } else {
668         locked = 0;
669     }
670
671     return (ret,cap,locked);
672 }
673
674 /* -----------------------------------------------------------------------------
675  * TVar primitives
676  * -------------------------------------------------------------------------- */
677
678 // Catch retry frame -----------------------------------------------------------
679
680 #define CATCH_RETRY_FRAME_FIELDS(w_,p_,info_ptr,        \
681                                  p1, p2,                \
682                                  running_alt_code,      \
683                                  first_code,            \
684                                  alt_code)              \
685   w_ info_ptr,                                          \
686   PROF_HDR_FIELDS(w_,p1,p2)                             \
687   w_ running_alt_code,                                  \
688   p_ first_code,                                        \
689   p_ alt_code
690
691
692 INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
693                CATCH_RETRY_FRAME_FIELDS(W_,P_,
694                                         info_ptr, p1, p2,
695                                         running_alt_code,
696                                         first_code,
697                                         alt_code))
698     return (P_ ret)
699 {
700     W_ r;
701     gcptr trec, outer, arg;
702
703     trec = StgTSO_trec(CurrentTSO);
704     outer  = StgTRecHeader_enclosing_trec(trec);
705     (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
706     if (r != 0) {
707         // Succeeded (either first branch or second branch)
708         StgTSO_trec(CurrentTSO) = outer;
709         return (ret);
710     } else {
711         // Did not commit: re-execute
712         P_ new_trec;
713         ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
714                                                            outer "ptr");
715         StgTSO_trec(CurrentTSO) = new_trec;
716         if (running_alt_code != 0) {
717             jump stg_ap_v_fast
718                 (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
719                                           running_alt_code,
720                                           first_code,
721                                           alt_code))
722                 (alt_code);
723         } else {
724             jump stg_ap_v_fast
725                 (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
726                                           running_alt_code,
727                                           first_code,
728                                           alt_code))
729                 (first_code);
730         }
731     }
732 }
733
734 // Atomically frame ------------------------------------------------------------
735
736 // This must match StgAtomicallyFrame in Closures.h
737 #define ATOMICALLY_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,next,result)  \
738   w_ info_ptr,                                                          \
739   PROF_HDR_FIELDS(w_,p1,p2)                                             \
740   p_ code,                                                              \
741   p_ next,                                                              \
742   p_ result
743
744
745 INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
746                // layout of the frame, and bind the field names
747                ATOMICALLY_FRAME_FIELDS(W_,P_,
748                                        info_ptr, p1, p2,
749                                        code,
750                                        next_invariant,
751                                        frame_result))
752     return (P_ result) // value returned to the frame
753 {
754   W_ valid;
755   gcptr trec, outer, next_invariant, q;
756
757   trec   = StgTSO_trec(CurrentTSO);
758   outer  = StgTRecHeader_enclosing_trec(trec);
759
760   if (outer == NO_TREC) {
761     /* First time back at the atomically frame -- pick up invariants */
762     ("ptr" next_invariant) =
763         ccall stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr");
764     frame_result = result;
765
766   } else {
767     /* Second/subsequent time back at the atomically frame -- abort the
768      * tx that's checking the invariant and move on to the next one */
769     StgTSO_trec(CurrentTSO) = outer;
770     StgInvariantCheckQueue_my_execution(next_invariant) = trec;
771     ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
772     /* Don't free trec -- it's linked from q and will be stashed in the
773      * invariant if we eventually commit. */
774     next_invariant =
775        StgInvariantCheckQueue_next_queue_entry(next_invariant);
776     trec = outer;
777   }
778
779   if (next_invariant != END_INVARIANT_CHECK_QUEUE) {
780     /* We can't commit yet: another invariant to check */
781     ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", trec "ptr");
782     StgTSO_trec(CurrentTSO) = trec;
783     q = StgInvariantCheckQueue_invariant(next_invariant);
784     jump stg_ap_v_fast
785         (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
786                                  code,next_invariant,frame_result))
787         (StgAtomicInvariant_code(q));
788
789   } else {
790
791     /* We've got no more invariants to check, try to commit */
792     (valid) = ccall stmCommitTransaction(MyCapability() "ptr", trec "ptr");
793     if (valid != 0) {
794       /* Transaction was valid: commit succeeded */
795       StgTSO_trec(CurrentTSO) = NO_TREC;
796       return (frame_result);
797     } else {
798       /* Transaction was not valid: try again */
799       ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
800       StgTSO_trec(CurrentTSO) = trec;
801       next_invariant = END_INVARIANT_CHECK_QUEUE;
802
803       jump stg_ap_v_fast
804           // push the StgAtomicallyFrame again: the code generator is
805           // clever enough to only assign the fields that have changed.
806           (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
807                                    code,next_invariant,frame_result))
808           (code);
809     }
810   }
811 }
812
813
814 INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
815                // layout of the frame, and bind the field names
816                ATOMICALLY_FRAME_FIELDS(W_,P_,
817                                        info_ptr, p1, p2,
818                                        code,
819                                        next_invariant,
820                                        frame_result))
821     return (/* no return values */)
822 {
823   W_ trec, valid;
824
825   /* The TSO is currently waiting: should we stop waiting? */
826   (valid) = ccall stmReWait(MyCapability() "ptr", CurrentTSO "ptr");
827   if (valid != 0) {
828       /* Previous attempt is still valid: no point trying again yet */
829       jump stg_block_noregs
830           (ATOMICALLY_FRAME_FIELDS(,,info_ptr, p1, p2,
831                                    code,next_invariant,frame_result))
832           ();
833   } else {
834     /* Previous attempt is no longer valid: try again */
835     ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
836     StgTSO_trec(CurrentTSO) = trec;
837
838     // change the frame header to stg_atomically_frame_info
839     jump stg_ap_v_fast
840         (ATOMICALLY_FRAME_FIELDS(,,stg_atomically_frame_info, p1, p2,
841                                  code,next_invariant,frame_result))
842         (code);
843   }
844 }
845
846 // STM catch frame -------------------------------------------------------------
847
848 /* Catch frames are very similar to update frames, but when entering
849  * one we just pop the frame off the stack and perform the correct
850  * kind of return to the activation record underneath us on the stack.
851  */
852
853 #define CATCH_STM_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,handler) \
854   w_ info_ptr,                                                  \
855   PROF_HDR_FIELDS(w_,p1,p2)                                     \
856   p_ code,                                                      \
857   p_ handler
858
859 INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
860                // layout of the frame, and bind the field names
861                CATCH_STM_FRAME_FIELDS(W_,P_,info_ptr,p1,p2,code,handler))
862     return (P_ ret)
863 {
864     W_ r, trec, outer;
865
866     trec = StgTSO_trec(CurrentTSO);
867     outer  = StgTRecHeader_enclosing_trec(trec);
868     (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
869     if (r != 0) {
870         /* Commit succeeded */
871         StgTSO_trec(CurrentTSO) = outer;
872         return (ret);
873     } else {
874         /* Commit failed */
875         W_ new_trec;
876         ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
877         StgTSO_trec(CurrentTSO) = new_trec;
878
879         jump stg_ap_v_fast
880             (CATCH_STM_FRAME_FIELDS(,,info_ptr,p1,p2,code,handler))
881             (code);
882     }
883 }
884
885
886 // Primop definition -----------------------------------------------------------
887
888 stg_atomicallyzh (P_ stm)
889 {
890   P_ old_trec;
891   P_ new_trec;
892   P_ code, next_invariant, frame_result;
893
894   // stmStartTransaction may allocate
895   MAYBE_GC_P(stg_atomicallyzh, stm);
896
897   STK_CHK_GEN();
898
899   old_trec = StgTSO_trec(CurrentTSO);
900
901   /* Nested transactions are not allowed; raise an exception */
902   if (old_trec != NO_TREC) {
903      jump stg_raisezh(base_ControlziExceptionziBase_nestedAtomically_closure);
904   }
905
906   code = stm;
907   next_invariant = END_INVARIANT_CHECK_QUEUE;
908   frame_result = NO_TREC;
909
910   /* Start the memory transcation */
911   ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr", old_trec "ptr");
912   StgTSO_trec(CurrentTSO) = new_trec;
913
914   jump stg_ap_v_fast
915       (ATOMICALLY_FRAME_FIELDS(,,stg_atomically_frame_info, CCCS, 0,
916                                code,next_invariant,frame_result))
917       (stm);
918 }
919
920 // A closure representing "atomically x".  This is used when a thread
921 // inside a transaction receives an asynchronous exception; see #5866.
922 // It is somewhat similar to the stg_raise closure.
923 //
924 INFO_TABLE(stg_atomically,1,0,THUNK_1_0,"atomically","atomically")
925     (P_ thunk)
926 {
927     jump stg_atomicallyzh(StgThunk_payload(thunk,0));
928 }
929
930
931 stg_catchSTMzh (P_ code    /* :: STM a */,
932                 P_ handler /* :: Exception -> STM a */)
933 {
934     STK_CHK_GEN();
935
936     /* Start a nested transaction to run the body of the try block in */
937     W_ cur_trec;
938     W_ new_trec;
939     cur_trec = StgTSO_trec(CurrentTSO);
940     ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
941                                                  cur_trec "ptr");
942     StgTSO_trec(CurrentTSO) = new_trec;
943
944     jump stg_ap_v_fast
945         (CATCH_STM_FRAME_FIELDS(,,stg_catch_stm_frame_info, CCCS, 0,
946                                 code, handler))
947         (code);
948 }
949
950
951 stg_catchRetryzh (P_ first_code, /* :: STM a */
952                   P_ alt_code    /* :: STM a */)
953 {
954   W_ new_trec;
955
956   // stmStartTransaction may allocate
957   MAYBE_GC_PP (stg_catchRetryzh, first_code, alt_code);
958
959   STK_CHK_GEN();
960
961   /* Start a nested transaction within which to run the first code */
962   ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
963                                                StgTSO_trec(CurrentTSO) "ptr");
964   StgTSO_trec(CurrentTSO) = new_trec;
965
966   // push the CATCH_RETRY stack frame, and apply first_code to realWorld#
967   jump stg_ap_v_fast
968       (CATCH_RETRY_FRAME_FIELDS(,, stg_catch_retry_frame_info, CCCS, 0,
969                                 0, /* not running_alt_code */
970                                 first_code,
971                                 alt_code))
972       (first_code);
973 }
974
975
976 stg_retryzh /* no arg list: explicit stack layout */
977 {
978   W_ frame_type;
979   W_ frame;
980   W_ trec;
981   W_ outer;
982   W_ r;
983
984   // STM operations may allocate
985   MAYBE_GC_ (stg_retryzh); // NB. not MAYBE_GC(), we cannot make a
986                            // function call in an explicit-stack proc
987
988   // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
989 retry_pop_stack:
990   SAVE_THREAD_STATE();
991   (frame_type) = ccall findRetryFrameHelper(MyCapability(), CurrentTSO "ptr");
992   LOAD_THREAD_STATE();
993   frame = Sp;
994   trec = StgTSO_trec(CurrentTSO);
995   outer  = StgTRecHeader_enclosing_trec(trec);
996
997   if (frame_type == CATCH_RETRY_FRAME) {
998     // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
999     ASSERT(outer != NO_TREC);
1000     // Abort the transaction attempting the current branch
1001     ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
1002     ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
1003     if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
1004       // Retry in the first branch: try the alternative
1005       ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
1006       StgTSO_trec(CurrentTSO) = trec;
1007       StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
1008       R1 = StgCatchRetryFrame_alt_code(frame);
1009       jump stg_ap_v_fast [R1];
1010     } else {
1011       // Retry in the alternative code: propagate the retry
1012       StgTSO_trec(CurrentTSO) = outer;
1013       Sp = Sp + SIZEOF_StgCatchRetryFrame;
1014       goto retry_pop_stack;
1015     }
1016   }
1017
1018   // We've reached the ATOMICALLY_FRAME: attempt to wait
1019   ASSERT(frame_type == ATOMICALLY_FRAME);
1020   if (outer != NO_TREC) {
1021     // We called retry while checking invariants, so abort the current
1022     // invariant check (merging its TVar accesses into the parents read
1023     // set so we'll wait on them)
1024     ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
1025     ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
1026     trec = outer;
1027     StgTSO_trec(CurrentTSO) = trec;
1028     outer  = StgTRecHeader_enclosing_trec(trec);
1029   }
1030   ASSERT(outer == NO_TREC);
1031
1032   (r) = ccall stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr");
1033   if (r != 0) {
1034     // Transaction was valid: stmWait put us on the TVars' queues, we now block
1035     StgHeader_info(frame) = stg_atomically_waiting_frame_info;
1036     Sp = frame;
1037     R3 = trec; // passing to stmWaitUnblock()
1038     jump stg_block_stmwait [R3];
1039   } else {
1040     // Transaction was not valid: retry immediately
1041     ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
1042     StgTSO_trec(CurrentTSO) = trec;
1043     Sp = frame;
1044     R1 = StgAtomicallyFrame_code(frame);
1045     jump stg_ap_v_fast [R1];
1046   }
1047 }
1048
1049 stg_checkzh (P_ closure /* STM a */)
1050 {
1051     W_ trec;
1052
1053     MAYBE_GC_P (stg_checkzh, closure);
1054
1055     trec = StgTSO_trec(CurrentTSO);
1056     ccall stmAddInvariantToCheck(MyCapability() "ptr",
1057                                  trec "ptr",
1058                                  closure "ptr");
1059     return ();
1060 }
1061
1062
1063 stg_newTVarzh (P_ init)
1064 {
1065     W_ tv;
1066
1067     ALLOC_PRIM_P (SIZEOF_StgTVar, stg_newTVarzh, init);
1068
1069     tv = Hp - SIZEOF_StgTVar + WDS(1);
1070     SET_HDR (tv, stg_TVAR_DIRTY_info, CCCS);
1071
1072     StgTVar_current_value(tv) = init;
1073     StgTVar_first_watch_queue_entry(tv) = stg_END_STM_WATCH_QUEUE_closure;
1074     StgTVar_num_updates(tv) = 0;
1075
1076     return (tv);
1077 }
1078
1079
1080 stg_readTVarzh (P_ tvar)
1081 {
1082   P_ trec;
1083   P_ result;
1084
1085   // Call to stmReadTVar may allocate
1086   MAYBE_GC_P (stg_readTVarzh, tvar);
1087
1088   trec = StgTSO_trec(CurrentTSO);
1089   ("ptr" result) = ccall stmReadTVar(MyCapability() "ptr", trec "ptr",
1090                                      tvar "ptr");
1091   return (result);
1092 }
1093
1094 stg_readTVarIOzh ( P_ tvar /* :: TVar a */ )
1095 {
1096     W_ result;
1097
1098 again:
1099     result = StgTVar_current_value(tvar);
1100     if (%INFO_PTR(result) == stg_TREC_HEADER_info) {
1101         goto again;
1102     }
1103     return (result);
1104 }
1105
1106 stg_writeTVarzh (P_ tvar,     /* :: TVar a */
1107                  P_ new_value /* :: a      */)
1108 {
1109     W_ trec;
1110
1111     // Call to stmWriteTVar may allocate
1112     MAYBE_GC_PP (stg_writeTVarzh, tvar, new_value);
1113
1114     trec = StgTSO_trec(CurrentTSO);
1115     ccall stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr",
1116                        new_value "ptr");
1117     return ();
1118 }
1119
1120
1121 /* -----------------------------------------------------------------------------
1122  * MVar primitives
1123  *
1124  * take & putMVar work as follows.  Firstly, an important invariant:
1125  *
1126  *    If the MVar is full, then the blocking queue contains only
1127  *    threads blocked on putMVar, and if the MVar is empty then the
1128  *    blocking queue contains only threads blocked on takeMVar.
1129  *
1130  * takeMvar:
1131  *    MVar empty : then add ourselves to the blocking queue
1132  *    MVar full  : remove the value from the MVar, and
1133  *                 blocking queue empty     : return
1134  *                 blocking queue non-empty : perform the first blocked putMVar
1135  *                                            from the queue, and wake up the
1136  *                                            thread (MVar is now full again)
1137  *
1138  * putMVar is just the dual of the above algorithm.
1139  *
1140  * How do we "perform a putMVar"?  Well, we have to fiddle around with
1141  * the stack of the thread waiting to do the putMVar.  See
1142  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
1143  * the stack layout, and the PerformPut and PerformTake macros below.
1144  *
1145  * It is important that a blocked take or put is woken up with the
1146  * take/put already performed, because otherwise there would be a
1147  * small window of vulnerability where the thread could receive an
1148  * exception and never perform its take or put, and we'd end up with a
1149  * deadlock.
1150  *
1151  * -------------------------------------------------------------------------- */
1152
1153 stg_isEmptyMVarzh ( P_ mvar /* :: MVar a */ )
1154 {
1155     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1156         return (1);
1157     } else {
1158         return (0);
1159     }
1160 }
1161
1162 stg_newMVarzh ()
1163 {
1164     W_ mvar;
1165
1166     ALLOC_PRIM_ (SIZEOF_StgMVar, stg_newMVarzh);
1167
1168     mvar = Hp - SIZEOF_StgMVar + WDS(1);
1169     SET_HDR(mvar,stg_MVAR_DIRTY_info,CCCS);
1170         // MVARs start dirty: generation 0 has no mutable list
1171     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
1172     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
1173     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1174     return (mvar);
1175 }
1176
1177
1178 #define PerformTake(stack, value)               \
1179     W_ sp;                                      \
1180     sp = StgStack_sp(stack);                    \
1181     W_[sp + WDS(1)] = value;                    \
1182     W_[sp + WDS(0)] = stg_ret_p_info;
1183
1184 #define PerformPut(stack,lval)                  \
1185     W_ sp;                                      \
1186     sp = StgStack_sp(stack) + WDS(3);           \
1187     StgStack_sp(stack) = sp;                    \
1188     lval = W_[sp - WDS(1)];
1189
1190
1191 stg_takeMVarzh ( P_ mvar /* :: MVar a */ )
1192 {
1193     W_ val, info, tso, q;
1194
1195 #if defined(THREADED_RTS)
1196     if (CInt[n_capabilities] == 1 :: CInt) {
1197         info = GET_INFO(mvar);
1198     }
1199     else {
1200         ("ptr" info) = ccall reallyLockClosure(mvar "ptr");
1201     }
1202 #else
1203     info = GET_INFO(mvar);
1204 #endif
1205
1206     /* If the MVar is empty, put ourselves on its blocking queue,
1207      * and wait until we're woken up.
1208      */
1209     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1210         if (info == stg_MVAR_CLEAN_info) {
1211             ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1212         }
1213
1214         // We want to put the heap check down here in the slow path,
1215         // but be careful to unlock the closure before returning to
1216         // the RTS if the check fails.
1217         ALLOC_PRIM_WITH_CUSTOM_FAILURE
1218             (SIZEOF_StgMVarTSOQueue,
1219              unlockClosure(mvar, stg_MVAR_DIRTY_info);
1220              GC_PRIM_P(stg_takeMVarzh, mvar));
1221
1222         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
1223
1224         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
1225         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
1226         StgMVarTSOQueue_tso(q)  = CurrentTSO;
1227
1228         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1229             StgMVar_head(mvar) = q;
1230         } else {
1231             StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
1232             ccall recordClosureMutated(MyCapability() "ptr",
1233                                              StgMVar_tail(mvar));
1234         }
1235         StgTSO__link(CurrentTSO)       = q;
1236         StgTSO_block_info(CurrentTSO)  = mvar;
1237         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1238         StgMVar_tail(mvar)             = q;
1239
1240         jump stg_block_takemvar(mvar);
1241     }
1242
1243     /* we got the value... */
1244     val = StgMVar_value(mvar);
1245
1246     q = StgMVar_head(mvar);
1247 loop:
1248     if (q == stg_END_TSO_QUEUE_closure) {
1249         /* No further putMVars, MVar is now empty */
1250         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1251         // If the MVar is not already dirty, then we don't need to make
1252         // it dirty, as it is empty with nothing blocking on it.
1253         unlockClosure(mvar, info);
1254         return (val);
1255     }
1256     if (StgHeader_info(q) == stg_IND_info ||
1257         StgHeader_info(q) == stg_MSG_NULL_info) {
1258         q = StgInd_indirectee(q);
1259         goto loop;
1260     }
1261
1262     // There are putMVar(s) waiting... wake up the first thread on the queue
1263
1264     if (info == stg_MVAR_CLEAN_info) {
1265         ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1266     }
1267
1268     tso = StgMVarTSOQueue_tso(q);
1269     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1270     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1271         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1272     }
1273
1274     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1275     ASSERT(StgTSO_block_info(tso) == mvar);
1276
1277     // actually perform the putMVar for the thread that we just woke up
1278     W_ stack;
1279     stack = StgTSO_stackobj(tso);
1280     PerformPut(stack, StgMVar_value(mvar));
1281
1282     // indicate that the MVar operation has now completed.
1283     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1284
1285     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
1286
1287     ccall tryWakeupThread(MyCapability() "ptr", tso);
1288
1289     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1290     return (val);
1291 }
1292
1293 stg_tryTakeMVarzh ( P_ mvar /* :: MVar a */ )
1294 {
1295     W_ val, info, tso, q;
1296
1297 #if defined(THREADED_RTS)
1298     if (CInt[n_capabilities] == 1 :: CInt) {
1299         info = GET_INFO(mvar);
1300     }
1301     else {
1302         ("ptr" info) = ccall reallyLockClosure(mvar "ptr");
1303     }
1304 #else
1305     info = GET_INFO(mvar);
1306 #endif
1307
1308     /* If the MVar is empty, return 0. */
1309     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1310 #if defined(THREADED_RTS)
1311         unlockClosure(mvar, info);
1312 #endif
1313         /* HACK: we need a pointer to pass back,
1314          * so we abuse NO_FINALIZER_closure
1315          */
1316         return (0, stg_NO_FINALIZER_closure);
1317     }
1318
1319     /* we got the value... */
1320     val = StgMVar_value(mvar);
1321
1322     q = StgMVar_head(mvar);
1323 loop:
1324     if (q == stg_END_TSO_QUEUE_closure) {
1325         /* No further putMVars, MVar is now empty */
1326         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1327         unlockClosure(mvar, info);
1328         return (1, val);
1329     }
1330
1331     if (StgHeader_info(q) == stg_IND_info ||
1332         StgHeader_info(q) == stg_MSG_NULL_info) {
1333         q = StgInd_indirectee(q);
1334         goto loop;
1335     }
1336
1337     // There are putMVar(s) waiting... wake up the first thread on the queue
1338
1339     if (info == stg_MVAR_CLEAN_info) {
1340         ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1341     }
1342
1343     tso = StgMVarTSOQueue_tso(q);
1344     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1345     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1346         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1347     }
1348
1349     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1350     ASSERT(StgTSO_block_info(tso) == mvar);
1351
1352     // actually perform the putMVar for the thread that we just woke up
1353     W_ stack;
1354     stack = StgTSO_stackobj(tso);
1355     PerformPut(stack, StgMVar_value(mvar));
1356
1357     // indicate that the MVar operation has now completed.
1358     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1359
1360     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
1361
1362     ccall tryWakeupThread(MyCapability() "ptr", tso);
1363
1364     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1365     return (1,val);
1366 }
1367
1368 stg_putMVarzh ( P_ mvar, /* :: MVar a */
1369                 P_ val,  /* :: a */ )
1370 {
1371     W_ info, tso, q;
1372
1373 #if defined(THREADED_RTS)
1374     if (CInt[n_capabilities] == 1 :: CInt) {
1375         info = GET_INFO(mvar);
1376     }
1377     else {
1378         ("ptr" info) = ccall reallyLockClosure(mvar "ptr");
1379     }
1380 #else
1381     info = GET_INFO(mvar);
1382 #endif
1383
1384     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
1385
1386         if (info == stg_MVAR_CLEAN_info) {
1387             ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1388         }
1389
1390         // We want to put the heap check down here in the slow path,
1391         // but be careful to unlock the closure before returning to
1392         // the RTS if the check fails.
1393         ALLOC_PRIM_WITH_CUSTOM_FAILURE
1394             (SIZEOF_StgMVarTSOQueue,
1395              unlockClosure(mvar, stg_MVAR_DIRTY_info);
1396              GC_PRIM_PP(stg_putMVarzh, mvar, val));
1397
1398         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
1399
1400         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
1401         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
1402         StgMVarTSOQueue_tso(q)  = CurrentTSO;
1403
1404         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1405             StgMVar_head(mvar) = q;
1406         } else {
1407             StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
1408             ccall recordClosureMutated(MyCapability() "ptr",
1409                                              StgMVar_tail(mvar));
1410         }
1411         StgTSO__link(CurrentTSO)       = q;
1412         StgTSO_block_info(CurrentTSO)  = mvar;
1413         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1414         StgMVar_tail(mvar)             = q;
1415
1416         jump stg_block_putmvar(mvar,val);
1417     }
1418
1419     q = StgMVar_head(mvar);
1420 loop:
1421     if (q == stg_END_TSO_QUEUE_closure) {
1422         /* No further takes, the MVar is now full. */
1423         if (info == stg_MVAR_CLEAN_info) {
1424             ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1425         }
1426         StgMVar_value(mvar) = val;
1427         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1428         return ();
1429     }
1430     if (StgHeader_info(q) == stg_IND_info ||
1431         StgHeader_info(q) == stg_MSG_NULL_info) {
1432         q = StgInd_indirectee(q);
1433         goto loop;
1434     }
1435
1436     // There are atomicReadMVar/takeMVar(s) waiting: wake up the first one
1437
1438     tso = StgMVarTSOQueue_tso(q);
1439     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1440     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1441         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1442     }
1443
1444     ASSERT(StgTSO_block_info(tso) == mvar);
1445     // save why_blocked here, because waking up the thread destroys
1446     // this information
1447     W_ why_blocked;
1448     why_blocked = TO_W_(StgTSO_why_blocked(tso));
1449
1450     // actually perform the takeMVar
1451     W_ stack;
1452     stack = StgTSO_stackobj(tso);
1453     PerformTake(stack, val);
1454
1455     // indicate that the MVar operation has now completed.
1456     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1457
1458     if (TO_W_(StgStack_dirty(stack)) == 0) {
1459         ccall dirty_STACK(MyCapability() "ptr", stack "ptr");
1460     }
1461
1462     ccall tryWakeupThread(MyCapability() "ptr", tso);
1463
1464     // If it was an atomicReadMVar, then we can still do work,
1465     // so loop back. (XXX: This could take a while)
1466     if (why_blocked == BlockedOnMVarRead) {
1467         q = StgMVarTSOQueue_link(q);
1468         goto loop;
1469     }
1470
1471     ASSERT(why_blocked == BlockedOnMVar);
1472
1473     unlockClosure(mvar, info);
1474     return ();
1475 }
1476
1477
1478 stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */
1479                    P_ val,  /* :: a */ )
1480 {
1481     W_ info, tso, q;
1482
1483 #if defined(THREADED_RTS)
1484     if (CInt[n_capabilities] == 1 :: CInt) {
1485         info = GET_INFO(mvar);
1486     }
1487     else {
1488         ("ptr" info) = ccall reallyLockClosure(mvar "ptr");
1489     }
1490 #else
1491     info = GET_INFO(mvar);
1492 #endif
1493
1494     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
1495 #if defined(THREADED_RTS)
1496         unlockClosure(mvar, info);
1497 #endif
1498         return (0);
1499     }
1500
1501     q = StgMVar_head(mvar);
1502 loop:
1503     if (q == stg_END_TSO_QUEUE_closure) {
1504         /* No further takes, the MVar is now full. */
1505         if (info == stg_MVAR_CLEAN_info) {
1506             ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1507         }
1508
1509         StgMVar_value(mvar) = val;
1510         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1511         return (1);
1512     }
1513     if (StgHeader_info(q) == stg_IND_info ||
1514         StgHeader_info(q) == stg_MSG_NULL_info) {
1515         q = StgInd_indirectee(q);
1516         goto loop;
1517     }
1518
1519     // There are takeMVar(s) waiting: wake up the first one
1520
1521     tso = StgMVarTSOQueue_tso(q);
1522     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1523     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1524         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1525     }
1526
1527     ASSERT(StgTSO_block_info(tso) == mvar);
1528     // save why_blocked here, because waking up the thread destroys
1529     // this information
1530     W_ why_blocked;
1531     why_blocked = TO_W_(StgTSO_why_blocked(tso));
1532
1533     // actually perform the takeMVar
1534     W_ stack;
1535     stack = StgTSO_stackobj(tso);
1536     PerformTake(stack, val);
1537
1538     // indicate that the MVar operation has now completed.
1539     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1540
1541     if (TO_W_(StgStack_dirty(stack)) == 0) {
1542         ccall dirty_STACK(MyCapability() "ptr", stack "ptr");
1543     }
1544
1545     ccall tryWakeupThread(MyCapability() "ptr", tso);
1546
1547     // If it was an atomicReadMVar, then we can still do work,
1548     // so loop back. (XXX: This could take a while)
1549     if (why_blocked == BlockedOnMVarRead) {
1550         q = StgMVarTSOQueue_link(q);
1551         goto loop;
1552     }
1553
1554     ASSERT(why_blocked == BlockedOnMVar);
1555
1556     unlockClosure(mvar, info);
1557     return (1);
1558 }
1559
1560 stg_atomicReadMVarzh ( P_ mvar, /* :: MVar a */ )
1561 {
1562     W_ val, info, tso, q;
1563
1564 #if defined(THREADED_RTS)
1565     ("ptr" info) = ccall lockClosure(mvar "ptr");
1566 #else
1567     info = GET_INFO(mvar);
1568 #endif
1569
1570     if (info == stg_MVAR_CLEAN_info) {
1571         ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1572     }
1573
1574     /* If the MVar is empty, put ourselves on the blocked readers
1575      * list and wait until we're woken up.
1576      */
1577     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1578
1579         ALLOC_PRIM_WITH_CUSTOM_FAILURE
1580             (SIZEOF_StgMVarTSOQueue,
1581              unlockClosure(mvar, stg_MVAR_DIRTY_info);
1582              GC_PRIM_P(stg_atomicReadMVarzh, mvar));
1583
1584         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
1585
1586         // readMVars are pushed to the front of the queue, so
1587         // they get handled immediately
1588         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
1589         StgMVarTSOQueue_link(q) = StgMVar_head(mvar);
1590         StgMVarTSOQueue_tso(q)  = CurrentTSO;
1591
1592         StgTSO__link(CurrentTSO)       = q;
1593         StgTSO_block_info(CurrentTSO)  = mvar;
1594         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16;
1595         StgMVar_head(mvar) = q;
1596
1597         if (StgMVar_tail(mvar) == stg_END_TSO_QUEUE_closure) {
1598             StgMVar_tail(mvar) = q;
1599         }
1600
1601         jump stg_block_atomicreadmvar(mvar);
1602     }
1603
1604     val = StgMVar_value(mvar);
1605
1606     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1607     return (val);
1608 }
1609
1610 /* -----------------------------------------------------------------------------
1611    Stable pointer primitives
1612    -------------------------------------------------------------------------  */
1613
1614 stg_makeStableNamezh ( P_ obj )
1615 {
1616     W_ index, sn_obj;
1617
1618     (index) = ccall lookupStableName(obj "ptr");
1619
1620     /* Is there already a StableName for this heap object?
1621      *  stable_name_table is a pointer to an array of snEntry structs.
1622      */
1623     if ( snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) == NULL ) {
1624         ALLOC_PRIM (SIZEOF_StgStableName);
1625         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1626         SET_HDR(sn_obj, stg_STABLE_NAME_info, CCCS);
1627         StgStableName_sn(sn_obj) = index;
1628         snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) = sn_obj;
1629     } else {
1630         sn_obj = snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry);
1631     }
1632
1633     return (sn_obj);
1634 }
1635
1636 stg_makeStablePtrzh ( P_ obj )
1637 {
1638     W_ sp;
1639
1640     ("ptr" sp) = ccall getStablePtr(obj "ptr");
1641     return (sp);
1642 }
1643
1644 stg_deRefStablePtrzh ( P_ sp )
1645 {
1646     W_ r;
1647     r = spEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_spEntry);
1648     return (r);
1649 }
1650
1651 /* -----------------------------------------------------------------------------
1652    Bytecode object primitives
1653    -------------------------------------------------------------------------  */
1654
1655 stg_newBCOzh ( P_ instrs,
1656                P_ literals,
1657                P_ ptrs,
1658                W_ arity,
1659                P_ bitmap_arr )
1660 {
1661     W_ bco, bytes, words;
1662
1663     words = BYTES_TO_WDS(SIZEOF_StgBCO) + BYTE_ARR_WDS(bitmap_arr);
1664     bytes = WDS(words);
1665
1666     ALLOC_PRIM (bytes);
1667
1668     bco = Hp - bytes + WDS(1);
1669     SET_HDR(bco, stg_BCO_info, CCCS);
1670
1671     StgBCO_instrs(bco)     = instrs;
1672     StgBCO_literals(bco)   = literals;
1673     StgBCO_ptrs(bco)       = ptrs;
1674     StgBCO_arity(bco)      = HALF_W_(arity);
1675     StgBCO_size(bco)       = HALF_W_(words);
1676
1677     // Copy the arity/bitmap info into the BCO
1678     W_ i;
1679     i = 0;
1680 for:
1681     if (i < BYTE_ARR_WDS(bitmap_arr)) {
1682         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1683         i = i + 1;
1684         goto for;
1685     }
1686
1687     return (bco);
1688 }
1689
1690 stg_mkApUpd0zh ( P_ bco )
1691 {
1692     W_ ap;
1693
1694     // This function is *only* used to wrap zero-arity BCOs in an
1695     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1696     // saturated and always points directly to a FUN or BCO.
1697     ASSERT(%INFO_TYPE(%GET_STD_INFO(bco)) == HALF_W_(BCO) &&
1698            StgBCO_arity(bco) == HALF_W_(0));
1699
1700     HP_CHK_P(SIZEOF_StgAP, stg_mkApUpd0zh, bco);
1701     TICK_ALLOC_UP_THK(0, 0);
1702     CCCS_ALLOC(SIZEOF_StgAP);
1703
1704     ap = Hp - SIZEOF_StgAP + WDS(1);
1705     SET_HDR(ap, stg_AP_info, CCCS);
1706
1707     StgAP_n_args(ap) = HALF_W_(0);
1708     StgAP_fun(ap) = bco;
1709
1710     return (ap);
1711 }
1712
1713 stg_unpackClosurezh ( P_ closure )
1714 {
1715 // TODO: Consider the absence of ptrs or nonptrs as a special case ?
1716
1717     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
1718     info  = %GET_STD_INFO(UNTAG(closure));
1719
1720     // Some closures have non-standard layout, so we omit those here.
1721     W_ type;
1722     type = TO_W_(%INFO_TYPE(info));
1723     switch [0 .. N_CLOSURE_TYPES] type {
1724     case THUNK_SELECTOR : {
1725         ptrs = 1;
1726         nptrs = 0;
1727         goto out;
1728     }
1729     case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,
1730          THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
1731         ptrs = 0;
1732         nptrs = 0;
1733         goto out;
1734     }
1735     default: {
1736         ptrs  = TO_W_(%INFO_PTRS(info));
1737         nptrs = TO_W_(%INFO_NPTRS(info));
1738         goto out;
1739     }}
1740 out:
1741
1742     W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
1743     nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
1744     ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
1745     ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
1746
1747     ALLOC_PRIM_P (ptrs_arr_sz + nptrs_arr_sz, stg_unpackClosurezh, closure);
1748
1749     W_ clos;
1750     clos = UNTAG(closure);
1751
1752     ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
1753     nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
1754
1755     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);
1756     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
1757     StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
1758
1759     p = 0;
1760 for:
1761     if(p < ptrs) {
1762          W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
1763          p = p + 1;
1764          goto for;
1765     }
1766     /* We can leave the card table uninitialised, since the array is
1767        allocated in the nursery.  The GC will fill it in if/when the array
1768        is promoted. */
1769
1770     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS);
1771     StgArrWords_bytes(nptrs_arr) = WDS(nptrs);
1772     p = 0;
1773 for2:
1774     if(p < nptrs) {
1775          W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
1776          p = p + 1;
1777          goto for2;
1778     }
1779     return (info, ptrs_arr, nptrs_arr);
1780 }
1781
1782 /* -----------------------------------------------------------------------------
1783    Thread I/O blocking primitives
1784    -------------------------------------------------------------------------- */
1785
1786 /* Add a thread to the end of the blocked queue. (C-- version of the C
1787  * macro in Schedule.h).
1788  */
1789 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1790     ASSERT(StgTSO__link(tso) == END_TSO_QUEUE);         \
1791     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1792       W_[blocked_queue_hd] = tso;                       \
1793     } else {                                            \
1794       ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \
1795     }                                                   \
1796     W_[blocked_queue_tl] = tso;
1797
1798 stg_waitReadzh ( W_ fd )
1799 {
1800 #ifdef THREADED_RTS
1801     ccall barf("waitRead# on threaded RTS") never returns;
1802 #else
1803
1804     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1805     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1806     StgTSO_block_info(CurrentTSO) = fd;
1807     // No locking - we're not going to use this interface in the
1808     // threaded RTS anyway.
1809     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1810     jump stg_block_noregs();
1811 #endif
1812 }
1813
1814 stg_waitWritezh ( W_ fd )
1815 {
1816 #ifdef THREADED_RTS
1817     ccall barf("waitWrite# on threaded RTS") never returns;
1818 #else
1819
1820     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1821     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1822     StgTSO_block_info(CurrentTSO) = fd;
1823     // No locking - we're not going to use this interface in the
1824     // threaded RTS anyway.
1825     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1826     jump stg_block_noregs();
1827 #endif
1828 }
1829
1830
1831 STRING(stg_delayzh_malloc_str, "stg_delayzh")
1832 stg_delayzh ( W_ us_delay )
1833 {
1834 #ifdef mingw32_HOST_OS
1835     W_ ares;
1836     CInt reqID;
1837 #else
1838     W_ t, prev, target;
1839 #endif
1840
1841 #ifdef THREADED_RTS
1842     ccall barf("delay# on threaded RTS") never returns;
1843 #else
1844
1845     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1846     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1847
1848 #ifdef mingw32_HOST_OS
1849
1850     /* could probably allocate this on the heap instead */
1851     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
1852                                         stg_delayzh_malloc_str);
1853     (reqID) = ccall addDelayRequest(us_delay);
1854     StgAsyncIOResult_reqID(ares)   = reqID;
1855     StgAsyncIOResult_len(ares)     = 0;
1856     StgAsyncIOResult_errCode(ares) = 0;
1857     StgTSO_block_info(CurrentTSO)  = ares;
1858
1859     /* Having all async-blocked threads reside on the blocked_queue
1860      * simplifies matters, so change the status to OnDoProc put the
1861      * delayed thread on the blocked_queue.
1862      */
1863     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1864     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1865     jump stg_block_async_void();
1866
1867 #else
1868
1869
1870     (target) = ccall getDelayTarget(us_delay);
1871
1872     StgTSO_block_info(CurrentTSO) = target;
1873
1874     /* Insert the new thread in the sleeping queue. */
1875     prev = NULL;
1876     t = W_[sleeping_queue];
1877 while:
1878     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1879         prev = t;
1880         t = StgTSO__link(t);
1881         goto while;
1882     }
1883
1884     StgTSO__link(CurrentTSO) = t;
1885     if (prev == NULL) {
1886         W_[sleeping_queue] = CurrentTSO;
1887     } else {
1888         ccall setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO);
1889     }
1890     jump stg_block_noregs();
1891 #endif
1892 #endif /* !THREADED_RTS */
1893 }
1894
1895
1896 #ifdef mingw32_HOST_OS
1897 STRING(stg_asyncReadzh_malloc_str, "stg_asyncReadzh")
1898 stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf )
1899 {
1900     W_ ares;
1901     CInt reqID;
1902
1903 #ifdef THREADED_RTS
1904     ccall barf("asyncRead# on threaded RTS") never returns;
1905 #else
1906
1907     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1908     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1909
1910     /* could probably allocate this on the heap instead */
1911     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
1912                                         stg_asyncReadzh_malloc_str);
1913     (reqID) = ccall addIORequest(fd, 0/*FALSE*/,is_sock,len,buf "ptr");
1914     StgAsyncIOResult_reqID(ares)   = reqID;
1915     StgAsyncIOResult_len(ares)     = 0;
1916     StgAsyncIOResult_errCode(ares) = 0;
1917     StgTSO_block_info(CurrentTSO)  = ares;
1918     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1919     jump stg_block_async();
1920 #endif
1921 }
1922
1923 STRING(stg_asyncWritezh_malloc_str, "stg_asyncWritezh")
1924 stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf )
1925 {
1926     W_ ares;
1927     CInt reqID;
1928
1929 #ifdef THREADED_RTS
1930     ccall barf("asyncWrite# on threaded RTS") never returns;
1931 #else
1932
1933     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1934     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1935
1936     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
1937                                         stg_asyncWritezh_malloc_str);
1938     (reqID) = ccall addIORequest(fd, 1/*TRUE*/,is_sock,len,buf "ptr");
1939
1940     StgAsyncIOResult_reqID(ares)   = reqID;
1941     StgAsyncIOResult_len(ares)     = 0;
1942     StgAsyncIOResult_errCode(ares) = 0;
1943     StgTSO_block_info(CurrentTSO)  = ares;
1944     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1945     jump stg_block_async();
1946 #endif
1947 }
1948
1949 STRING(stg_asyncDoProczh_malloc_str, "stg_asyncDoProczh")
1950 stg_asyncDoProczh ( W_ proc, W_ param )
1951 {
1952     W_ ares;
1953     CInt reqID;
1954
1955 #ifdef THREADED_RTS
1956     ccall barf("asyncDoProc# on threaded RTS") never returns;
1957 #else
1958
1959     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1960     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1961
1962     /* could probably allocate this on the heap instead */
1963     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
1964                                         stg_asyncDoProczh_malloc_str);
1965     (reqID) = ccall addDoProcRequest(proc "ptr",param "ptr");
1966     StgAsyncIOResult_reqID(ares)   = reqID;
1967     StgAsyncIOResult_len(ares)     = 0;
1968     StgAsyncIOResult_errCode(ares) = 0;
1969     StgTSO_block_info(CurrentTSO) = ares;
1970     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1971     jump stg_block_async();
1972 #endif
1973 }
1974 #endif
1975
1976 /* -----------------------------------------------------------------------------
1977  * noDuplicate#
1978  *
1979  * noDuplicate# tries to ensure that none of the thunks under
1980  * evaluation by the current thread are also under evaluation by
1981  * another thread.  It relies on *both* threads doing noDuplicate#;
1982  * the second one will get blocked if they are duplicating some work.
1983  *
1984  * The idea is that noDuplicate# is used within unsafePerformIO to
1985  * ensure that the IO operation is performed at most once.
1986  * noDuplicate# calls threadPaused which acquires an exclusive lock on
1987  * all the thunks currently under evaluation by the current thread.
1988  *
1989  * Consider the following scenario.  There is a thunk A, whose
1990  * evaluation requires evaluating thunk B, where thunk B is an
1991  * unsafePerformIO.  Two threads, 1 and 2, bother enter A.  Thread 2
1992  * is pre-empted before it enters B, and claims A by blackholing it
1993  * (in threadPaused).  Thread 1 now enters B, and calls noDuplicate#.
1994  *
1995  *      thread 1                      thread 2
1996  *   +-----------+                 +---------------+
1997  *   |    -------+-----> A <-------+-------        |
1998  *   |  update   |   BLACKHOLE     | marked_update |
1999  *   +-----------+                 +---------------+
2000  *   |           |                 |               |
2001  *        ...                             ...
2002  *   |           |                 +---------------+
2003  *   +-----------+
2004  *   |     ------+-----> B
2005  *   |  update   |   BLACKHOLE
2006  *   +-----------+
2007  *
2008  * At this point: A is a blackhole, owned by thread 2.  noDuplicate#
2009  * calls threadPaused, which walks up the stack and
2010  *  - claims B on behalf of thread 1
2011  *  - then it reaches the update frame for A, which it sees is already
2012  *    a BLACKHOLE and is therefore owned by another thread.  Since
2013  *    thread 1 is duplicating work, the computation up to the update
2014  *    frame for A is suspended, including thunk B.
2015  *  - thunk B, which is an unsafePerformIO, has now been reverted to
2016  *    an AP_STACK which could be duplicated - BAD!
2017  *  - The solution is as follows: before calling threadPaused, we
2018  *    leave a frame on the stack (stg_noDuplicate_info) that will call
2019  *    noDuplicate# again if the current computation is suspended and
2020  *    restarted.
2021  *
2022  * See the test program in concurrent/prog003 for a way to demonstrate
2023  * this.  It needs to be run with +RTS -N3 or greater, and the bug
2024  * only manifests occasionally (once very 10 runs or so).
2025  * -------------------------------------------------------------------------- */
2026
2027 INFO_TABLE_RET(stg_noDuplicate, RET_SMALL, W_ info_ptr)
2028     return (/* no return values */)
2029 {
2030     jump stg_noDuplicatezh();
2031 }
2032
2033 stg_noDuplicatezh /* no arg list: explicit stack layout */
2034 {
2035     STK_CHK(WDS(1), stg_noDuplicatezh);
2036
2037     // leave noDuplicate frame in case the current
2038     // computation is suspended and restarted (see above).
2039     Sp_adj(-1);
2040     Sp(0) = stg_noDuplicate_info;
2041
2042     SAVE_THREAD_STATE();
2043     ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
2044     ccall threadPaused (MyCapability() "ptr", CurrentTSO "ptr");
2045
2046     if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
2047         jump stg_threadFinished [];
2048     } else {
2049         LOAD_THREAD_STATE();
2050         ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
2051         // remove the stg_noDuplicate frame if it is still there.
2052         if (Sp(0) == stg_noDuplicate_info) {
2053             Sp_adj(1);
2054         }
2055         jump %ENTRY_CODE(Sp(0)) [];
2056     }
2057 }
2058
2059 /* -----------------------------------------------------------------------------
2060    Misc. primitives
2061    -------------------------------------------------------------------------- */
2062
2063 stg_getApStackValzh ( P_ ap_stack, W_ offset )
2064 {
2065    if (%INFO_PTR(ap_stack) == stg_AP_STACK_info) {
2066        return (1,StgAP_STACK_payload(ap_stack,offset));
2067    } else {
2068        return (0,ap_stack);
2069    }
2070 }
2071
2072 // Write the cost center stack of the first argument on stderr; return
2073 // the second.  Possibly only makes sense for already evaluated
2074 // things?
2075 stg_traceCcszh ( P_ obj, P_ ret )
2076 {
2077     W_ ccs;
2078
2079 #ifdef PROFILING
2080     ccs = StgHeader_ccs(UNTAG(obj));
2081     ccall fprintCCS_stderr(ccs "ptr");
2082 #endif
2083
2084     jump stg_ap_0_fast(ret);
2085 }
2086
2087 stg_getSparkzh ()
2088 {
2089    W_ spark;
2090
2091 #ifndef THREADED_RTS
2092    return (0,ghczmprim_GHCziTypes_False_closure);
2093 #else
2094    (spark) = ccall findSpark(MyCapability());
2095    if (spark != 0) {
2096       return (1,spark);
2097    } else {
2098       return (0,ghczmprim_GHCziTypes_False_closure);
2099    }
2100 #endif
2101 }
2102
2103 stg_numSparkszh ()
2104 {
2105   W_ n;
2106 #ifdef THREADED_RTS
2107   (n) = ccall dequeElements(Capability_sparks(MyCapability()));
2108 #else
2109   n = 0;
2110 #endif
2111   return (n);
2112 }
2113
2114 stg_traceEventzh ( W_ msg )
2115 {
2116 #if defined(TRACING) || defined(DEBUG)
2117
2118    ccall traceUserMsg(MyCapability() "ptr", msg "ptr");
2119
2120 #elif defined(DTRACE)
2121
2122    W_ enabled;
2123
2124    // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
2125    // RtsProbes.h, but that header file includes unistd.h, which doesn't
2126    // work in Cmm
2127 #if !defined(solaris2_TARGET_OS)
2128    (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__msg$v1();
2129 #else
2130    // Solaris' DTrace can't handle the
2131    //     __dtrace_isenabled$HaskellEvent$user__msg$v1
2132    // call above. This call is just for testing whether the user__msg
2133    // probe is enabled, and is here for just performance optimization.
2134    // Since preparation for the probe is not that complex I disable usage of
2135    // this test above for Solaris and enable the probe usage manually
2136    // here. Please note that this does not mean that the probe will be
2137    // used during the runtime! You still need to enable it by consumption
2138    // in your dtrace script as you do with any other probe.
2139    enabled = 1;
2140 #endif
2141    if (enabled != 0) {
2142      ccall dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr");
2143    }
2144
2145 #endif
2146    return ();
2147 }
2148
2149 // Same code as stg_traceEventzh above but a different kind of event
2150 // Before changing this code, read the comments in the impl above
2151 stg_traceMarkerzh ( W_ msg )
2152 {
2153 #if defined(TRACING) || defined(DEBUG)
2154
2155    ccall traceUserMarker(MyCapability() "ptr", msg "ptr");
2156
2157 #elif defined(DTRACE)
2158
2159    W_ enabled;
2160
2161 #if !defined(solaris2_TARGET_OS)
2162    (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__marker$v1();
2163 #else
2164    enabled = 1;
2165 #endif
2166    if (enabled != 0) {
2167      ccall dtraceUserMarkerWrapper(MyCapability() "ptr", msg "ptr");
2168    }
2169
2170 #endif
2171    return ();
2172 }
2173