Optimization for takeMVar/putMVar when MVar left empty; fixes #7923
[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   // We don't care about cfinalizer here.
378   // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or
379   // something else?
380
381   StgWeak_key(w)        = key;
382   StgWeak_value(w)      = value;
383   StgWeak_finalizer(w)  = finalizer;
384   StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure;
385
386   ACQUIRE_LOCK(sm_mutex);
387   StgWeak_link(w)       = W_[weak_ptr_list];
388   W_[weak_ptr_list]     = w;
389   RELEASE_LOCK(sm_mutex);
390
391   IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
392
393   return (w);
394 }
395
396 stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
397 {
398   jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
399 }
400
401 stg_mkWeakForeignEnvzh ( gcptr key,
402                          gcptr val,
403                          W_ fptr,   // finalizer
404                          W_ ptr,
405                          W_ flag,   // has environment (0 or 1)
406                          W_ eptr )
407 {
408   W_ payload_words, words;
409   gcptr w, p;
410
411   ALLOC_PRIM (SIZEOF_StgWeak);
412
413   w = Hp - SIZEOF_StgWeak + WDS(1);
414   SET_HDR(w, stg_WEAK_info, CCCS);
415
416   payload_words = 4;
417   words         = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
418   ("ptr" p)     = ccall allocate(MyCapability() "ptr", words);
419
420   TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
421   SET_HDR(p, stg_ARR_WORDS_info, CCCS);
422
423   StgArrWords_bytes(p)     = WDS(payload_words);
424   StgArrWords_payload(p,0) = fptr;
425   StgArrWords_payload(p,1) = ptr;
426   StgArrWords_payload(p,2) = eptr;
427   StgArrWords_payload(p,3) = flag;
428
429   // We don't care about the value here.
430   // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else?
431
432   StgWeak_key(w)        = key;
433   StgWeak_value(w)      = val;
434   StgWeak_finalizer(w)  = stg_NO_FINALIZER_closure;
435   StgWeak_cfinalizer(w) = p;
436
437   ACQUIRE_LOCK(sm_mutex);
438   StgWeak_link(w)   = W_[weak_ptr_list];
439   W_[weak_ptr_list] = w;
440   RELEASE_LOCK(sm_mutex);
441
442   IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
443
444   return (w);
445 }
446
447 stg_finalizzeWeakzh ( gcptr w )
448 {
449   gcptr f, arr;
450
451   // already dead?
452   if (GET_INFO(w) == stg_DEAD_WEAK_info) {
453       return (0,stg_NO_FINALIZER_closure);
454   }
455
456   // kill it
457 #ifdef PROFILING
458   // @LDV profiling
459   // A weak pointer is inherently used, so we do not need to call
460   // LDV_recordDead_FILL_SLOP_DYNAMIC():
461   //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
462   // or, LDV_recordDead():
463   //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
464   // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
465   // large as weak pointers, so there is no need to fill the slop, either.
466   // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
467 #endif
468
469   //
470   // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
471   //
472   SET_INFO(w,stg_DEAD_WEAK_info);
473   LDV_RECORD_CREATE(w);
474
475   f   = StgWeak_finalizer(w);
476   arr = StgWeak_cfinalizer(w);
477
478   StgDeadWeak_link(w) = StgWeak_link(w);
479
480   if (arr != stg_NO_FINALIZER_closure) {
481     ccall runCFinalizer(StgArrWords_payload(arr,0),
482                               StgArrWords_payload(arr,1),
483                               StgArrWords_payload(arr,2),
484                               StgArrWords_payload(arr,3));
485   }
486
487   /* return the finalizer */
488   if (f == stg_NO_FINALIZER_closure) {
489       return (0,stg_NO_FINALIZER_closure);
490   } else {
491       return (1,f);
492   }
493 }
494
495 stg_deRefWeakzh ( gcptr w )
496 {
497   W_ code;
498   gcptr val;
499
500   if (GET_INFO(w) == stg_WEAK_info) {
501     code = 1;
502     val = StgWeak_value(w);
503   } else {
504     code = 0;
505     val = w;
506   }
507   return (code,val);
508 }
509
510 /* -----------------------------------------------------------------------------
511    Floating point operations.
512    -------------------------------------------------------------------------- */
513
514 stg_decodeFloatzuIntzh ( F_ arg )
515 {
516     W_ p;
517     W_ mp_tmp1;
518     W_ mp_tmp_w;
519
520     STK_CHK_GEN_N (WDS(2));
521
522     mp_tmp1  = Sp - WDS(1);
523     mp_tmp_w = Sp - WDS(2);
524
525     /* Perform the operation */
526     ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
527
528     /* returns: (Int# (mantissa), Int# (exponent)) */
529     return (W_[mp_tmp1], W_[mp_tmp_w]);
530 }
531
532 stg_decodeDoublezu2Intzh ( D_ arg )
533 {
534     W_ p;
535     W_ mp_tmp1;
536     W_ mp_tmp2;
537     W_ mp_result1;
538     W_ mp_result2;
539
540     STK_CHK_GEN_N (WDS(4));
541
542     mp_tmp1    = Sp - WDS(1);
543     mp_tmp2    = Sp - WDS(2);
544     mp_result1 = Sp - WDS(3);
545     mp_result2 = Sp - WDS(4);
546
547     /* Perform the operation */
548     ccall __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
549                                     mp_result1 "ptr", mp_result2 "ptr",
550                                     arg);
551
552     /* returns:
553        (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
554     return (W_[mp_tmp1], W_[mp_tmp2], W_[mp_result1], W_[mp_result2]);
555 }
556
557 /* -----------------------------------------------------------------------------
558  * Concurrency primitives
559  * -------------------------------------------------------------------------- */
560
561 stg_forkzh ( gcptr closure )
562 {
563   MAYBE_GC_P(stg_forkzh, closure);
564
565   gcptr threadid;
566
567   ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
568                                 RtsFlags_GcFlags_initialStkSize(RtsFlags),
569                                 closure "ptr");
570
571   /* start blocked if the current thread is blocked */
572   StgTSO_flags(threadid) = %lobits16(
573      TO_W_(StgTSO_flags(threadid)) |
574      TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
575
576   ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
577
578   // context switch soon, but not immediately: we don't want every
579   // forkIO to force a context-switch.
580   Capability_context_switch(MyCapability()) = 1 :: CInt;
581
582   return (threadid);
583 }
584
585 stg_forkOnzh ( W_ cpu, gcptr closure )
586 {
587 again: MAYBE_GC(again);
588
589   gcptr threadid;
590
591   ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
592                                 RtsFlags_GcFlags_initialStkSize(RtsFlags),
593                                 closure "ptr");
594
595   /* start blocked if the current thread is blocked */
596   StgTSO_flags(threadid) = %lobits16(
597      TO_W_(StgTSO_flags(threadid)) |
598      TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
599
600   ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr");
601
602   // context switch soon, but not immediately: we don't want every
603   // forkIO to force a context-switch.
604   Capability_context_switch(MyCapability()) = 1 :: CInt;
605
606   return (threadid);
607 }
608
609 stg_yieldzh ()
610 {
611   // when we yield to the scheduler, we have to tell it to put the
612   // current thread to the back of the queue by setting the
613   // context_switch flag.  If we don't do this, it will run the same
614   // thread again.
615   Capability_context_switch(MyCapability()) = 1 :: CInt;
616   jump stg_yield_noregs();
617 }
618
619 stg_myThreadIdzh ()
620 {
621   return (CurrentTSO);
622 }
623
624 stg_labelThreadzh ( gcptr threadid, W_ addr )
625 {
626 #if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
627   ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
628 #endif
629   return ();
630 }
631
632 stg_isCurrentThreadBoundzh (/* no args */)
633 {
634   W_ r;
635   (r) = ccall isThreadBound(CurrentTSO);
636   return (r);
637 }
638
639 stg_threadStatuszh ( gcptr tso )
640 {
641     W_ why_blocked;
642     W_ what_next;
643     W_ ret, cap, locked;
644
645     what_next   = TO_W_(StgTSO_what_next(tso));
646     why_blocked = TO_W_(StgTSO_why_blocked(tso));
647     // Note: these two reads are not atomic, so they might end up
648     // being inconsistent.  It doesn't matter, since we
649     // only return one or the other.  If we wanted to return the
650     // contents of block_info too, then we'd have to do some synchronisation.
651
652     if (what_next == ThreadComplete) {
653         ret = 16;  // NB. magic, matches up with GHC.Conc.threadStatus
654     } else {
655         if (what_next == ThreadKilled) {
656             ret = 17;
657         } else {
658             ret = why_blocked;
659         }
660     }
661
662     cap = TO_W_(Capability_no(StgTSO_cap(tso)));
663
664     if ((TO_W_(StgTSO_flags(tso)) & TSO_LOCKED) != 0) {
665         locked = 1;
666     } else {
667         locked = 0;
668     }
669
670     return (ret,cap,locked);
671 }
672
673 /* -----------------------------------------------------------------------------
674  * TVar primitives
675  * -------------------------------------------------------------------------- */
676
677 // Catch retry frame -----------------------------------------------------------
678
679 #define CATCH_RETRY_FRAME_FIELDS(w_,p_,info_ptr,        \
680                                  p1, p2,                \
681                                  running_alt_code,      \
682                                  first_code,            \
683                                  alt_code)              \
684   w_ info_ptr,                                          \
685   PROF_HDR_FIELDS(w_,p1,p2)                             \
686   w_ running_alt_code,                                  \
687   p_ first_code,                                        \
688   p_ alt_code
689
690
691 INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
692                CATCH_RETRY_FRAME_FIELDS(W_,P_,
693                                         info_ptr, p1, p2,
694                                         running_alt_code,
695                                         first_code,
696                                         alt_code))
697     return (P_ ret)
698 {
699     W_ r;
700     gcptr trec, outer, arg;
701
702     trec = StgTSO_trec(CurrentTSO);
703     outer  = StgTRecHeader_enclosing_trec(trec);
704     (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
705     if (r != 0) {
706         // Succeeded (either first branch or second branch)
707         StgTSO_trec(CurrentTSO) = outer;
708         return (ret);
709     } else {
710         // Did not commit: re-execute
711         P_ new_trec;
712         ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
713                                                            outer "ptr");
714         StgTSO_trec(CurrentTSO) = new_trec;
715         if (running_alt_code != 0) {
716             jump stg_ap_v_fast
717                 (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
718                                           running_alt_code,
719                                           first_code,
720                                           alt_code))
721                 (alt_code);
722         } else {
723             jump stg_ap_v_fast
724                 (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
725                                           running_alt_code,
726                                           first_code,
727                                           alt_code))
728                 (first_code);
729         }
730     }
731 }
732
733 // Atomically frame ------------------------------------------------------------
734
735 // This must match StgAtomicallyFrame in Closures.h
736 #define ATOMICALLY_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,next,result)  \
737   w_ info_ptr,                                                          \
738   PROF_HDR_FIELDS(w_,p1,p2)                                             \
739   p_ code,                                                              \
740   p_ next,                                                              \
741   p_ result
742
743
744 INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
745                // layout of the frame, and bind the field names
746                ATOMICALLY_FRAME_FIELDS(W_,P_,
747                                        info_ptr, p1, p2,
748                                        code,
749                                        next_invariant,
750                                        frame_result))
751     return (P_ result) // value returned to the frame
752 {
753   W_ valid;
754   gcptr trec, outer, next_invariant, q;
755
756   trec   = StgTSO_trec(CurrentTSO);
757   outer  = StgTRecHeader_enclosing_trec(trec);
758
759   if (outer == NO_TREC) {
760     /* First time back at the atomically frame -- pick up invariants */
761     ("ptr" next_invariant) =
762         ccall stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr");
763     frame_result = result;
764
765   } else {
766     /* Second/subsequent time back at the atomically frame -- abort the
767      * tx that's checking the invariant and move on to the next one */
768     StgTSO_trec(CurrentTSO) = outer;
769     StgInvariantCheckQueue_my_execution(next_invariant) = trec;
770     ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
771     /* Don't free trec -- it's linked from q and will be stashed in the
772      * invariant if we eventually commit. */
773     next_invariant =
774        StgInvariantCheckQueue_next_queue_entry(next_invariant);
775     trec = outer;
776   }
777
778   if (next_invariant != END_INVARIANT_CHECK_QUEUE) {
779     /* We can't commit yet: another invariant to check */
780     ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", trec "ptr");
781     StgTSO_trec(CurrentTSO) = trec;
782     q = StgInvariantCheckQueue_invariant(next_invariant);
783     jump stg_ap_v_fast
784         (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
785                                  code,next_invariant,frame_result))
786         (StgAtomicInvariant_code(q));
787
788   } else {
789
790     /* We've got no more invariants to check, try to commit */
791     (valid) = ccall stmCommitTransaction(MyCapability() "ptr", trec "ptr");
792     if (valid != 0) {
793       /* Transaction was valid: commit succeeded */
794       StgTSO_trec(CurrentTSO) = NO_TREC;
795       return (frame_result);
796     } else {
797       /* Transaction was not valid: try again */
798       ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
799       StgTSO_trec(CurrentTSO) = trec;
800       next_invariant = END_INVARIANT_CHECK_QUEUE;
801
802       jump stg_ap_v_fast
803           // push the StgAtomicallyFrame again: the code generator is
804           // clever enough to only assign the fields that have changed.
805           (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
806                                    code,next_invariant,frame_result))
807           (code);
808     }
809   }
810 }
811
812
813 INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
814                // layout of the frame, and bind the field names
815                ATOMICALLY_FRAME_FIELDS(W_,P_,
816                                        info_ptr, p1, p2,
817                                        code,
818                                        next_invariant,
819                                        frame_result))
820     return (/* no return values */)
821 {
822   W_ trec, valid;
823
824   /* The TSO is currently waiting: should we stop waiting? */
825   (valid) = ccall stmReWait(MyCapability() "ptr", CurrentTSO "ptr");
826   if (valid != 0) {
827       /* Previous attempt is still valid: no point trying again yet */
828       jump stg_block_noregs
829           (ATOMICALLY_FRAME_FIELDS(,,info_ptr, p1, p2,
830                                    code,next_invariant,frame_result))
831           ();
832   } else {
833     /* Previous attempt is no longer valid: try again */
834     ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
835     StgTSO_trec(CurrentTSO) = trec;
836
837     // change the frame header to stg_atomically_frame_info
838     jump stg_ap_v_fast
839         (ATOMICALLY_FRAME_FIELDS(,,stg_atomically_frame_info, p1, p2,
840                                  code,next_invariant,frame_result))
841         (code);
842   }
843 }
844
845 // STM catch frame -------------------------------------------------------------
846
847 /* Catch frames are very similar to update frames, but when entering
848  * one we just pop the frame off the stack and perform the correct
849  * kind of return to the activation record underneath us on the stack.
850  */
851
852 #define CATCH_STM_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,handler) \
853   w_ info_ptr,                                                  \
854   PROF_HDR_FIELDS(w_,p1,p2)                                     \
855   p_ code,                                                      \
856   p_ handler
857
858 INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
859                // layout of the frame, and bind the field names
860                CATCH_STM_FRAME_FIELDS(W_,P_,info_ptr,p1,p2,code,handler))
861     return (P_ ret)
862 {
863     W_ r, trec, outer;
864
865     trec = StgTSO_trec(CurrentTSO);
866     outer  = StgTRecHeader_enclosing_trec(trec);
867     (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
868     if (r != 0) {
869         /* Commit succeeded */
870         StgTSO_trec(CurrentTSO) = outer;
871         return (ret);
872     } else {
873         /* Commit failed */
874         W_ new_trec;
875         ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
876         StgTSO_trec(CurrentTSO) = new_trec;
877
878         jump stg_ap_v_fast
879             (CATCH_STM_FRAME_FIELDS(,,info_ptr,p1,p2,code,handler))
880             (code);
881     }
882 }
883
884
885 // Primop definition -----------------------------------------------------------
886
887 stg_atomicallyzh (P_ stm)
888 {
889   P_ old_trec;
890   P_ new_trec;
891   P_ code, next_invariant, frame_result;
892
893   // stmStartTransaction may allocate
894   MAYBE_GC_P(stg_atomicallyzh, stm);
895
896   STK_CHK_GEN();
897
898   old_trec = StgTSO_trec(CurrentTSO);
899
900   /* Nested transactions are not allowed; raise an exception */
901   if (old_trec != NO_TREC) {
902      jump stg_raisezh(base_ControlziExceptionziBase_nestedAtomically_closure);
903   }
904
905   code = stm;
906   next_invariant = END_INVARIANT_CHECK_QUEUE;
907   frame_result = NO_TREC;
908
909   /* Start the memory transcation */
910   ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr", old_trec "ptr");
911   StgTSO_trec(CurrentTSO) = new_trec;
912
913   jump stg_ap_v_fast
914       (ATOMICALLY_FRAME_FIELDS(,,stg_atomically_frame_info, CCCS, 0,
915                                code,next_invariant,frame_result))
916       (stm);
917 }
918
919 // A closure representing "atomically x".  This is used when a thread
920 // inside a transaction receives an asynchronous exception; see #5866.
921 // It is somewhat similar to the stg_raise closure.
922 //
923 INFO_TABLE(stg_atomically,1,0,THUNK_1_0,"atomically","atomically")
924     (P_ thunk)
925 {
926     jump stg_atomicallyzh(StgThunk_payload(thunk,0));
927 }
928
929
930 stg_catchSTMzh (P_ code    /* :: STM a */,
931                 P_ handler /* :: Exception -> STM a */)
932 {
933     STK_CHK_GEN();
934
935     /* Start a nested transaction to run the body of the try block in */
936     W_ cur_trec;
937     W_ new_trec;
938     cur_trec = StgTSO_trec(CurrentTSO);
939     ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
940                                                  cur_trec "ptr");
941     StgTSO_trec(CurrentTSO) = new_trec;
942
943     jump stg_ap_v_fast
944         (CATCH_STM_FRAME_FIELDS(,,stg_catch_stm_frame_info, CCCS, 0,
945                                 code, handler))
946         (code);
947 }
948
949
950 stg_catchRetryzh (P_ first_code, /* :: STM a */
951                   P_ alt_code    /* :: STM a */)
952 {
953   W_ new_trec;
954
955   // stmStartTransaction may allocate
956   MAYBE_GC_PP (stg_catchRetryzh, first_code, alt_code);
957
958   STK_CHK_GEN();
959
960   /* Start a nested transaction within which to run the first code */
961   ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
962                                                StgTSO_trec(CurrentTSO) "ptr");
963   StgTSO_trec(CurrentTSO) = new_trec;
964
965   // push the CATCH_RETRY stack frame, and apply first_code to realWorld#
966   jump stg_ap_v_fast
967       (CATCH_RETRY_FRAME_FIELDS(,, stg_catch_retry_frame_info, CCCS, 0,
968                                 0, /* not running_alt_code */
969                                 first_code,
970                                 alt_code))
971       (first_code);
972 }
973
974
975 stg_retryzh /* no arg list: explicit stack layout */
976 {
977   W_ frame_type;
978   W_ frame;
979   W_ trec;
980   W_ outer;
981   W_ r;
982
983   // STM operations may allocate
984   MAYBE_GC_ (stg_retryzh); // NB. not MAYBE_GC(), we cannot make a
985                            // function call in an explicit-stack proc
986
987   // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
988 retry_pop_stack:
989   SAVE_THREAD_STATE();
990   (frame_type) = ccall findRetryFrameHelper(MyCapability(), CurrentTSO "ptr");
991   LOAD_THREAD_STATE();
992   frame = Sp;
993   trec = StgTSO_trec(CurrentTSO);
994   outer  = StgTRecHeader_enclosing_trec(trec);
995
996   if (frame_type == CATCH_RETRY_FRAME) {
997     // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
998     ASSERT(outer != NO_TREC);
999     // Abort the transaction attempting the current branch
1000     ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
1001     ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
1002     if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
1003       // Retry in the first branch: try the alternative
1004       ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
1005       StgTSO_trec(CurrentTSO) = trec;
1006       StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
1007       R1 = StgCatchRetryFrame_alt_code(frame);
1008       jump stg_ap_v_fast [R1];
1009     } else {
1010       // Retry in the alternative code: propagate the retry
1011       StgTSO_trec(CurrentTSO) = outer;
1012       Sp = Sp + SIZEOF_StgCatchRetryFrame;
1013       goto retry_pop_stack;
1014     }
1015   }
1016
1017   // We've reached the ATOMICALLY_FRAME: attempt to wait
1018   ASSERT(frame_type == ATOMICALLY_FRAME);
1019   if (outer != NO_TREC) {
1020     // We called retry while checking invariants, so abort the current
1021     // invariant check (merging its TVar accesses into the parents read
1022     // set so we'll wait on them)
1023     ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
1024     ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
1025     trec = outer;
1026     StgTSO_trec(CurrentTSO) = trec;
1027     outer  = StgTRecHeader_enclosing_trec(trec);
1028   }
1029   ASSERT(outer == NO_TREC);
1030
1031   (r) = ccall stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr");
1032   if (r != 0) {
1033     // Transaction was valid: stmWait put us on the TVars' queues, we now block
1034     StgHeader_info(frame) = stg_atomically_waiting_frame_info;
1035     Sp = frame;
1036     R3 = trec; // passing to stmWaitUnblock()
1037     jump stg_block_stmwait [R3];
1038   } else {
1039     // Transaction was not valid: retry immediately
1040     ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
1041     StgTSO_trec(CurrentTSO) = trec;
1042     Sp = frame;
1043     R1 = StgAtomicallyFrame_code(frame);
1044     jump stg_ap_v_fast [R1];
1045   }
1046 }
1047
1048 stg_checkzh (P_ closure /* STM a */)
1049 {
1050     W_ trec;
1051
1052     MAYBE_GC_P (stg_checkzh, closure);
1053
1054     trec = StgTSO_trec(CurrentTSO);
1055     ccall stmAddInvariantToCheck(MyCapability() "ptr",
1056                                  trec "ptr",
1057                                  closure "ptr");
1058     return ();
1059 }
1060
1061
1062 stg_newTVarzh (P_ init)
1063 {
1064     W_ tv;
1065
1066     ALLOC_PRIM_P (SIZEOF_StgTVar, stg_newTVarzh, init);
1067
1068     tv = Hp - SIZEOF_StgTVar + WDS(1);
1069     SET_HDR (tv, stg_TVAR_DIRTY_info, CCCS);
1070
1071     StgTVar_current_value(tv) = init;
1072     StgTVar_first_watch_queue_entry(tv) = stg_END_STM_WATCH_QUEUE_closure;
1073     StgTVar_num_updates(tv) = 0;
1074
1075     return (tv);
1076 }
1077
1078
1079 stg_readTVarzh (P_ tvar)
1080 {
1081   P_ trec;
1082   P_ result;
1083
1084   // Call to stmReadTVar may allocate
1085   MAYBE_GC_P (stg_readTVarzh, tvar);
1086
1087   trec = StgTSO_trec(CurrentTSO);
1088   ("ptr" result) = ccall stmReadTVar(MyCapability() "ptr", trec "ptr",
1089                                      tvar "ptr");
1090   return (result);
1091 }
1092
1093 stg_readTVarIOzh ( P_ tvar /* :: TVar a */ )
1094 {
1095     W_ result;
1096
1097 again:
1098     result = StgTVar_current_value(tvar);
1099     if (%INFO_PTR(result) == stg_TREC_HEADER_info) {
1100         goto again;
1101     }
1102     return (result);
1103 }
1104
1105 stg_writeTVarzh (P_ tvar,     /* :: TVar a */
1106                  P_ new_value /* :: a      */)
1107 {
1108     W_ trec;
1109
1110     // Call to stmWriteTVar may allocate
1111     MAYBE_GC_PP (stg_writeTVarzh, tvar, new_value);
1112
1113     trec = StgTSO_trec(CurrentTSO);
1114     ccall stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr",
1115                        new_value "ptr");
1116     return ();
1117 }
1118
1119
1120 /* -----------------------------------------------------------------------------
1121  * MVar primitives
1122  *
1123  * take & putMVar work as follows.  Firstly, an important invariant:
1124  *
1125  *    If the MVar is full, then the blocking queue contains only
1126  *    threads blocked on putMVar, and if the MVar is empty then the
1127  *    blocking queue contains only threads blocked on takeMVar.
1128  *
1129  * takeMvar:
1130  *    MVar empty : then add ourselves to the blocking queue
1131  *    MVar full  : remove the value from the MVar, and
1132  *                 blocking queue empty     : return
1133  *                 blocking queue non-empty : perform the first blocked putMVar
1134  *                                            from the queue, and wake up the
1135  *                                            thread (MVar is now full again)
1136  *
1137  * putMVar is just the dual of the above algorithm.
1138  *
1139  * How do we "perform a putMVar"?  Well, we have to fiddle around with
1140  * the stack of the thread waiting to do the putMVar.  See
1141  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
1142  * the stack layout, and the PerformPut and PerformTake macros below.
1143  *
1144  * It is important that a blocked take or put is woken up with the
1145  * take/put already performed, because otherwise there would be a
1146  * small window of vulnerability where the thread could receive an
1147  * exception and never perform its take or put, and we'd end up with a
1148  * deadlock.
1149  *
1150  * -------------------------------------------------------------------------- */
1151
1152 stg_isEmptyMVarzh ( P_ mvar /* :: MVar a */ )
1153 {
1154     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1155         return (1);
1156     } else {
1157         return (0);
1158     }
1159 }
1160
1161 stg_newMVarzh ()
1162 {
1163     W_ mvar;
1164
1165     ALLOC_PRIM_ (SIZEOF_StgMVar, stg_newMVarzh);
1166
1167     mvar = Hp - SIZEOF_StgMVar + WDS(1);
1168     SET_HDR(mvar,stg_MVAR_DIRTY_info,CCCS);
1169         // MVARs start dirty: generation 0 has no mutable list
1170     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
1171     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
1172     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1173     return (mvar);
1174 }
1175
1176
1177 #define PerformTake(stack, value)               \
1178     W_ sp;                                      \
1179     sp = StgStack_sp(stack);                    \
1180     W_[sp + WDS(1)] = value;                    \
1181     W_[sp + WDS(0)] = stg_ret_p_info;
1182
1183 #define PerformPut(stack,lval)                  \
1184     W_ sp;                                      \
1185     sp = StgStack_sp(stack) + WDS(3);           \
1186     StgStack_sp(stack) = sp;                    \
1187     lval = W_[sp - WDS(1)];
1188
1189
1190 stg_takeMVarzh ( P_ mvar /* :: MVar a */ )
1191 {
1192     W_ val, info, tso, q;
1193
1194 #if defined(THREADED_RTS)
1195     ("ptr" info) = ccall lockClosure(mvar "ptr");
1196 #else
1197     info = GET_INFO(mvar);
1198 #endif
1199
1200     /* If the MVar is empty, put ourselves on its blocking queue,
1201      * and wait until we're woken up.
1202      */
1203     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1204         if (info == stg_MVAR_CLEAN_info) {
1205             ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1206         }
1207
1208         // We want to put the heap check down here in the slow path,
1209         // but be careful to unlock the closure before returning to
1210         // the RTS if the check fails.
1211         ALLOC_PRIM_WITH_CUSTOM_FAILURE
1212             (SIZEOF_StgMVarTSOQueue,
1213              unlockClosure(mvar, stg_MVAR_DIRTY_info);
1214              GC_PRIM_P(stg_takeMVarzh, mvar));
1215
1216         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
1217
1218         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
1219         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
1220         StgMVarTSOQueue_tso(q)  = CurrentTSO;
1221
1222         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1223             StgMVar_head(mvar) = q;
1224         } else {
1225             StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
1226             ccall recordClosureMutated(MyCapability() "ptr",
1227                                              StgMVar_tail(mvar));
1228         }
1229         StgTSO__link(CurrentTSO)       = q;
1230         StgTSO_block_info(CurrentTSO)  = mvar;
1231         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1232         StgMVar_tail(mvar)             = q;
1233
1234         jump stg_block_takemvar(mvar);
1235     }
1236
1237     /* we got the value... */
1238     val = StgMVar_value(mvar);
1239
1240     q = StgMVar_head(mvar);
1241 loop:
1242     if (q == stg_END_TSO_QUEUE_closure) {
1243         /* No further putMVars, MVar is now empty */
1244         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1245         // If the MVar is not already dirty, then we don't need to make
1246         // it dirty, as it is empty with nothing blocking on it.
1247         unlockClosure(mvar, info);
1248         return (val);
1249     }
1250     if (StgHeader_info(q) == stg_IND_info ||
1251         StgHeader_info(q) == stg_MSG_NULL_info) {
1252         q = StgInd_indirectee(q);
1253         goto loop;
1254     }
1255
1256     // There are putMVar(s) waiting... wake up the first thread on the queue
1257
1258     if (info == stg_MVAR_CLEAN_info) {
1259         ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1260     }
1261
1262     tso = StgMVarTSOQueue_tso(q);
1263     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1264     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1265         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1266     }
1267
1268     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1269     ASSERT(StgTSO_block_info(tso) == mvar);
1270
1271     // actually perform the putMVar for the thread that we just woke up
1272     W_ stack;
1273     stack = StgTSO_stackobj(tso);
1274     PerformPut(stack, StgMVar_value(mvar));
1275
1276     // indicate that the MVar operation has now completed.
1277     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1278
1279     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
1280
1281     ccall tryWakeupThread(MyCapability() "ptr", tso);
1282
1283     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1284     return (val);
1285 }
1286
1287 stg_tryTakeMVarzh ( P_ mvar /* :: MVar a */ )
1288 {
1289     W_ val, info, tso, q;
1290
1291 #if defined(THREADED_RTS)
1292     ("ptr" info) = ccall lockClosure(mvar "ptr");
1293 #else
1294     info = GET_INFO(mvar);
1295 #endif
1296
1297     /* If the MVar is empty, return 0. */
1298     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1299 #if defined(THREADED_RTS)
1300         unlockClosure(mvar, info);
1301 #endif
1302         /* HACK: we need a pointer to pass back,
1303          * so we abuse NO_FINALIZER_closure
1304          */
1305         return (0, stg_NO_FINALIZER_closure);
1306     }
1307
1308     /* we got the value... */
1309     val = StgMVar_value(mvar);
1310
1311     q = StgMVar_head(mvar);
1312 loop:
1313     if (q == stg_END_TSO_QUEUE_closure) {
1314         /* No further putMVars, MVar is now empty */
1315         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1316         unlockClosure(mvar, info);
1317         return (1, val);
1318     }
1319
1320     if (StgHeader_info(q) == stg_IND_info ||
1321         StgHeader_info(q) == stg_MSG_NULL_info) {
1322         q = StgInd_indirectee(q);
1323         goto loop;
1324     }
1325
1326     // There are putMVar(s) waiting... wake up the first thread on the queue
1327
1328     if (info == stg_MVAR_CLEAN_info) {
1329         ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1330     }
1331
1332     tso = StgMVarTSOQueue_tso(q);
1333     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1334     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1335         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1336     }
1337
1338     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1339     ASSERT(StgTSO_block_info(tso) == mvar);
1340
1341     // actually perform the putMVar for the thread that we just woke up
1342     W_ stack;
1343     stack = StgTSO_stackobj(tso);
1344     PerformPut(stack, StgMVar_value(mvar));
1345
1346     // indicate that the MVar operation has now completed.
1347     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1348
1349     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
1350
1351     ccall tryWakeupThread(MyCapability() "ptr", tso);
1352
1353     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1354     return (1,val);
1355 }
1356
1357 stg_putMVarzh ( P_ mvar, /* :: MVar a */
1358                 P_ val,  /* :: a */ )
1359 {
1360     W_ info, tso, q;
1361
1362 #if defined(THREADED_RTS)
1363     ("ptr" info) = ccall lockClosure(mvar "ptr");
1364 #else
1365     info = GET_INFO(mvar);
1366 #endif
1367
1368     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
1369
1370         if (info == stg_MVAR_CLEAN_info) {
1371             ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1372         }
1373
1374         // We want to put the heap check down here in the slow path,
1375         // but be careful to unlock the closure before returning to
1376         // the RTS if the check fails.
1377         ALLOC_PRIM_WITH_CUSTOM_FAILURE
1378             (SIZEOF_StgMVarTSOQueue,
1379              unlockClosure(mvar, stg_MVAR_DIRTY_info);
1380              GC_PRIM_PP(stg_putMVarzh, mvar, val));
1381
1382         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
1383
1384         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
1385         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
1386         StgMVarTSOQueue_tso(q)  = CurrentTSO;
1387
1388         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1389             StgMVar_head(mvar) = q;
1390         } else {
1391             StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
1392             ccall recordClosureMutated(MyCapability() "ptr",
1393                                              StgMVar_tail(mvar));
1394         }
1395         StgTSO__link(CurrentTSO)       = q;
1396         StgTSO_block_info(CurrentTSO)  = mvar;
1397         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1398         StgMVar_tail(mvar)             = q;
1399
1400         jump stg_block_putmvar(mvar,val);
1401     }
1402
1403     q = StgMVar_head(mvar);
1404 loop:
1405     if (q == stg_END_TSO_QUEUE_closure) {
1406         /* No further takes, the MVar is now full. */
1407         if (info == stg_MVAR_CLEAN_info) {
1408             ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1409         }
1410         StgMVar_value(mvar) = val;
1411         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1412         return ();
1413     }
1414     if (StgHeader_info(q) == stg_IND_info ||
1415         StgHeader_info(q) == stg_MSG_NULL_info) {
1416         q = StgInd_indirectee(q);
1417         goto loop;
1418     }
1419
1420     // There are takeMVar(s) waiting: wake up the first one
1421
1422     tso = StgMVarTSOQueue_tso(q);
1423     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1424     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1425         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1426     }
1427
1428     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1429     ASSERT(StgTSO_block_info(tso) == mvar);
1430
1431     // actually perform the takeMVar
1432     W_ stack;
1433     stack = StgTSO_stackobj(tso);
1434     PerformTake(stack, val);
1435
1436     // indicate that the MVar operation has now completed.
1437     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1438
1439     if (TO_W_(StgStack_dirty(stack)) == 0) {
1440         ccall dirty_STACK(MyCapability() "ptr", stack "ptr");
1441     }
1442
1443     ccall tryWakeupThread(MyCapability() "ptr", tso);
1444
1445     unlockClosure(mvar, info);
1446     return ();
1447 }
1448
1449
1450 stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */
1451                    P_ val,  /* :: a */ )
1452 {
1453     W_ info, tso, q;
1454
1455 #if defined(THREADED_RTS)
1456     ("ptr" info) = ccall lockClosure(mvar "ptr");
1457 #else
1458     info = GET_INFO(mvar);
1459 #endif
1460
1461     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
1462 #if defined(THREADED_RTS)
1463         unlockClosure(mvar, info);
1464 #endif
1465         return (0);
1466     }
1467
1468     q = StgMVar_head(mvar);
1469 loop:
1470     if (q == stg_END_TSO_QUEUE_closure) {
1471         /* No further takes, the MVar is now full. */
1472         if (info == stg_MVAR_CLEAN_info) {
1473             ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
1474         }
1475
1476         StgMVar_value(mvar) = val;
1477         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1478         return (1);
1479     }
1480     if (StgHeader_info(q) == stg_IND_info ||
1481         StgHeader_info(q) == stg_MSG_NULL_info) {
1482         q = StgInd_indirectee(q);
1483         goto loop;
1484     }
1485
1486     // There are takeMVar(s) waiting: wake up the first one
1487
1488     tso = StgMVarTSOQueue_tso(q);
1489     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1490     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1491         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1492     }
1493
1494     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1495     ASSERT(StgTSO_block_info(tso) == mvar);
1496
1497     // actually perform the takeMVar
1498     W_ stack;
1499     stack = StgTSO_stackobj(tso);
1500     PerformTake(stack, val);
1501
1502     // indicate that the MVar operation has now completed.
1503     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1504
1505     if (TO_W_(StgStack_dirty(stack)) == 0) {
1506         ccall dirty_STACK(MyCapability() "ptr", stack "ptr");
1507     }
1508
1509     ccall tryWakeupThread(MyCapability() "ptr", tso);
1510
1511     unlockClosure(mvar, info);
1512     return (1);
1513 }
1514
1515
1516 /* -----------------------------------------------------------------------------
1517    Stable pointer primitives
1518    -------------------------------------------------------------------------  */
1519
1520 stg_makeStableNamezh ( P_ obj )
1521 {
1522     W_ index, sn_obj;
1523
1524     (index) = ccall lookupStableName(obj "ptr");
1525
1526     /* Is there already a StableName for this heap object?
1527      *  stable_name_table is a pointer to an array of snEntry structs.
1528      */
1529     if ( snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) == NULL ) {
1530         ALLOC_PRIM (SIZEOF_StgStableName);
1531         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1532         SET_HDR(sn_obj, stg_STABLE_NAME_info, CCCS);
1533         StgStableName_sn(sn_obj) = index;
1534         snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) = sn_obj;
1535     } else {
1536         sn_obj = snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry);
1537     }
1538
1539     return (sn_obj);
1540 }
1541
1542 stg_makeStablePtrzh ( P_ obj )
1543 {
1544     W_ sp;
1545
1546     ("ptr" sp) = ccall getStablePtr(obj "ptr");
1547     return (sp);
1548 }
1549
1550 stg_deRefStablePtrzh ( P_ sp )
1551 {
1552     W_ r;
1553     r = spEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_spEntry);
1554     return (r);
1555 }
1556
1557 /* -----------------------------------------------------------------------------
1558    Bytecode object primitives
1559    -------------------------------------------------------------------------  */
1560
1561 stg_newBCOzh ( P_ instrs,
1562                P_ literals,
1563                P_ ptrs,
1564                W_ arity,
1565                P_ bitmap_arr )
1566 {
1567     W_ bco, bytes, words;
1568
1569     words = BYTES_TO_WDS(SIZEOF_StgBCO) + BYTE_ARR_WDS(bitmap_arr);
1570     bytes = WDS(words);
1571
1572     ALLOC_PRIM (bytes);
1573
1574     bco = Hp - bytes + WDS(1);
1575     SET_HDR(bco, stg_BCO_info, CCCS);
1576
1577     StgBCO_instrs(bco)     = instrs;
1578     StgBCO_literals(bco)   = literals;
1579     StgBCO_ptrs(bco)       = ptrs;
1580     StgBCO_arity(bco)      = HALF_W_(arity);
1581     StgBCO_size(bco)       = HALF_W_(words);
1582
1583     // Copy the arity/bitmap info into the BCO
1584     W_ i;
1585     i = 0;
1586 for:
1587     if (i < BYTE_ARR_WDS(bitmap_arr)) {
1588         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1589         i = i + 1;
1590         goto for;
1591     }
1592
1593     return (bco);
1594 }
1595
1596 stg_mkApUpd0zh ( P_ bco )
1597 {
1598     W_ ap;
1599
1600     // This function is *only* used to wrap zero-arity BCOs in an
1601     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1602     // saturated and always points directly to a FUN or BCO.
1603     ASSERT(%INFO_TYPE(%GET_STD_INFO(bco)) == HALF_W_(BCO) &&
1604            StgBCO_arity(bco) == HALF_W_(0));
1605
1606     HP_CHK_P(SIZEOF_StgAP, stg_mkApUpd0zh, bco);
1607     TICK_ALLOC_UP_THK(0, 0);
1608     CCCS_ALLOC(SIZEOF_StgAP);
1609
1610     ap = Hp - SIZEOF_StgAP + WDS(1);
1611     SET_HDR(ap, stg_AP_info, CCCS);
1612
1613     StgAP_n_args(ap) = HALF_W_(0);
1614     StgAP_fun(ap) = bco;
1615
1616     return (ap);
1617 }
1618
1619 stg_unpackClosurezh ( P_ closure )
1620 {
1621 // TODO: Consider the absence of ptrs or nonptrs as a special case ?
1622
1623     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
1624     info  = %GET_STD_INFO(UNTAG(closure));
1625
1626     // Some closures have non-standard layout, so we omit those here.
1627     W_ type;
1628     type = TO_W_(%INFO_TYPE(info));
1629     switch [0 .. N_CLOSURE_TYPES] type {
1630     case THUNK_SELECTOR : {
1631         ptrs = 1;
1632         nptrs = 0;
1633         goto out;
1634     }
1635     case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,
1636          THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
1637         ptrs = 0;
1638         nptrs = 0;
1639         goto out;
1640     }
1641     default: {
1642         ptrs  = TO_W_(%INFO_PTRS(info));
1643         nptrs = TO_W_(%INFO_NPTRS(info));
1644         goto out;
1645     }}
1646 out:
1647
1648     W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
1649     nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
1650     ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
1651     ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
1652
1653     ALLOC_PRIM_P (ptrs_arr_sz + nptrs_arr_sz, stg_unpackClosurezh, closure);
1654
1655     W_ clos;
1656     clos = UNTAG(closure);
1657
1658     ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
1659     nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
1660
1661     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);
1662     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
1663     StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
1664
1665     p = 0;
1666 for:
1667     if(p < ptrs) {
1668          W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
1669          p = p + 1;
1670          goto for;
1671     }
1672     /* We can leave the card table uninitialised, since the array is
1673        allocated in the nursery.  The GC will fill it in if/when the array
1674        is promoted. */
1675
1676     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS);
1677     StgArrWords_bytes(nptrs_arr) = WDS(nptrs);
1678     p = 0;
1679 for2:
1680     if(p < nptrs) {
1681          W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
1682          p = p + 1;
1683          goto for2;
1684     }
1685     return (info, ptrs_arr, nptrs_arr);
1686 }
1687
1688 /* -----------------------------------------------------------------------------
1689    Thread I/O blocking primitives
1690    -------------------------------------------------------------------------- */
1691
1692 /* Add a thread to the end of the blocked queue. (C-- version of the C
1693  * macro in Schedule.h).
1694  */
1695 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1696     ASSERT(StgTSO__link(tso) == END_TSO_QUEUE);         \
1697     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1698       W_[blocked_queue_hd] = tso;                       \
1699     } else {                                            \
1700       ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \
1701     }                                                   \
1702     W_[blocked_queue_tl] = tso;
1703
1704 stg_waitReadzh ( W_ fd )
1705 {
1706 #ifdef THREADED_RTS
1707     ccall barf("waitRead# on threaded RTS") never returns;
1708 #else
1709
1710     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1711     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1712     StgTSO_block_info(CurrentTSO) = fd;
1713     // No locking - we're not going to use this interface in the
1714     // threaded RTS anyway.
1715     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1716     jump stg_block_noregs();
1717 #endif
1718 }
1719
1720 stg_waitWritezh ( W_ fd )
1721 {
1722 #ifdef THREADED_RTS
1723     ccall barf("waitWrite# on threaded RTS") never returns;
1724 #else
1725
1726     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1727     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1728     StgTSO_block_info(CurrentTSO) = fd;
1729     // No locking - we're not going to use this interface in the
1730     // threaded RTS anyway.
1731     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1732     jump stg_block_noregs();
1733 #endif
1734 }
1735
1736
1737 STRING(stg_delayzh_malloc_str, "stg_delayzh")
1738 stg_delayzh ( W_ us_delay )
1739 {
1740 #ifdef mingw32_HOST_OS
1741     W_ ares;
1742     CInt reqID;
1743 #else
1744     W_ t, prev, target;
1745 #endif
1746
1747 #ifdef THREADED_RTS
1748     ccall barf("delay# on threaded RTS") never returns;
1749 #else
1750
1751     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1752     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1753
1754 #ifdef mingw32_HOST_OS
1755
1756     /* could probably allocate this on the heap instead */
1757     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
1758                                         stg_delayzh_malloc_str);
1759     (reqID) = ccall addDelayRequest(us_delay);
1760     StgAsyncIOResult_reqID(ares)   = reqID;
1761     StgAsyncIOResult_len(ares)     = 0;
1762     StgAsyncIOResult_errCode(ares) = 0;
1763     StgTSO_block_info(CurrentTSO)  = ares;
1764
1765     /* Having all async-blocked threads reside on the blocked_queue
1766      * simplifies matters, so change the status to OnDoProc put the
1767      * delayed thread on the blocked_queue.
1768      */
1769     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1770     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1771     jump stg_block_async_void();
1772
1773 #else
1774
1775
1776     (target) = ccall getDelayTarget(us_delay);
1777
1778     StgTSO_block_info(CurrentTSO) = target;
1779
1780     /* Insert the new thread in the sleeping queue. */
1781     prev = NULL;
1782     t = W_[sleeping_queue];
1783 while:
1784     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1785         prev = t;
1786         t = StgTSO__link(t);
1787         goto while;
1788     }
1789
1790     StgTSO__link(CurrentTSO) = t;
1791     if (prev == NULL) {
1792         W_[sleeping_queue] = CurrentTSO;
1793     } else {
1794         ccall setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO);
1795     }
1796     jump stg_block_noregs();
1797 #endif
1798 #endif /* !THREADED_RTS */
1799 }
1800
1801
1802 #ifdef mingw32_HOST_OS
1803 STRING(stg_asyncReadzh_malloc_str, "stg_asyncReadzh")
1804 stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf )
1805 {
1806     W_ ares;
1807     CInt reqID;
1808
1809 #ifdef THREADED_RTS
1810     ccall barf("asyncRead# on threaded RTS") never returns;
1811 #else
1812
1813     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1814     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1815
1816     /* could probably allocate this on the heap instead */
1817     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
1818                                         stg_asyncReadzh_malloc_str);
1819     (reqID) = ccall addIORequest(fd, 0/*FALSE*/,is_sock,len,buf "ptr");
1820     StgAsyncIOResult_reqID(ares)   = reqID;
1821     StgAsyncIOResult_len(ares)     = 0;
1822     StgAsyncIOResult_errCode(ares) = 0;
1823     StgTSO_block_info(CurrentTSO)  = ares;
1824     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1825     jump stg_block_async();
1826 #endif
1827 }
1828
1829 STRING(stg_asyncWritezh_malloc_str, "stg_asyncWritezh")
1830 stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf )
1831 {
1832     W_ ares;
1833     CInt reqID;
1834
1835 #ifdef THREADED_RTS
1836     ccall barf("asyncWrite# on threaded RTS") never returns;
1837 #else
1838
1839     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1840     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1841
1842     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
1843                                         stg_asyncWritezh_malloc_str);
1844     (reqID) = ccall addIORequest(fd, 1/*TRUE*/,is_sock,len,buf "ptr");
1845
1846     StgAsyncIOResult_reqID(ares)   = reqID;
1847     StgAsyncIOResult_len(ares)     = 0;
1848     StgAsyncIOResult_errCode(ares) = 0;
1849     StgTSO_block_info(CurrentTSO)  = ares;
1850     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1851     jump stg_block_async();
1852 #endif
1853 }
1854
1855 STRING(stg_asyncDoProczh_malloc_str, "stg_asyncDoProczh")
1856 stg_asyncDoProczh ( W_ proc, W_ param )
1857 {
1858     W_ ares;
1859     CInt reqID;
1860
1861 #ifdef THREADED_RTS
1862     ccall barf("asyncDoProc# on threaded RTS") never returns;
1863 #else
1864
1865     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1866     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1867
1868     /* could probably allocate this on the heap instead */
1869     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
1870                                         stg_asyncDoProczh_malloc_str);
1871     (reqID) = ccall addDoProcRequest(proc "ptr",param "ptr");
1872     StgAsyncIOResult_reqID(ares)   = reqID;
1873     StgAsyncIOResult_len(ares)     = 0;
1874     StgAsyncIOResult_errCode(ares) = 0;
1875     StgTSO_block_info(CurrentTSO) = ares;
1876     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1877     jump stg_block_async();
1878 #endif
1879 }
1880 #endif
1881
1882 /* -----------------------------------------------------------------------------
1883  * noDuplicate#
1884  *
1885  * noDuplicate# tries to ensure that none of the thunks under
1886  * evaluation by the current thread are also under evaluation by
1887  * another thread.  It relies on *both* threads doing noDuplicate#;
1888  * the second one will get blocked if they are duplicating some work.
1889  *
1890  * The idea is that noDuplicate# is used within unsafePerformIO to
1891  * ensure that the IO operation is performed at most once.
1892  * noDuplicate# calls threadPaused which acquires an exclusive lock on
1893  * all the thunks currently under evaluation by the current thread.
1894  *
1895  * Consider the following scenario.  There is a thunk A, whose
1896  * evaluation requires evaluating thunk B, where thunk B is an
1897  * unsafePerformIO.  Two threads, 1 and 2, bother enter A.  Thread 2
1898  * is pre-empted before it enters B, and claims A by blackholing it
1899  * (in threadPaused).  Thread 1 now enters B, and calls noDuplicate#.
1900  *
1901  *      thread 1                      thread 2
1902  *   +-----------+                 +---------------+
1903  *   |    -------+-----> A <-------+-------        |
1904  *   |  update   |   BLACKHOLE     | marked_update |
1905  *   +-----------+                 +---------------+
1906  *   |           |                 |               |
1907  *        ...                             ...
1908  *   |           |                 +---------------+
1909  *   +-----------+
1910  *   |     ------+-----> B
1911  *   |  update   |   BLACKHOLE
1912  *   +-----------+
1913  *
1914  * At this point: A is a blackhole, owned by thread 2.  noDuplicate#
1915  * calls threadPaused, which walks up the stack and
1916  *  - claims B on behalf of thread 1
1917  *  - then it reaches the update frame for A, which it sees is already
1918  *    a BLACKHOLE and is therefore owned by another thread.  Since
1919  *    thread 1 is duplicating work, the computation up to the update
1920  *    frame for A is suspended, including thunk B.
1921  *  - thunk B, which is an unsafePerformIO, has now been reverted to
1922  *    an AP_STACK which could be duplicated - BAD!
1923  *  - The solution is as follows: before calling threadPaused, we
1924  *    leave a frame on the stack (stg_noDuplicate_info) that will call
1925  *    noDuplicate# again if the current computation is suspended and
1926  *    restarted.
1927  *
1928  * See the test program in concurrent/prog003 for a way to demonstrate
1929  * this.  It needs to be run with +RTS -N3 or greater, and the bug
1930  * only manifests occasionally (once very 10 runs or so).
1931  * -------------------------------------------------------------------------- */
1932
1933 INFO_TABLE_RET(stg_noDuplicate, RET_SMALL, W_ info_ptr)
1934     return (/* no return values */)
1935 {
1936     jump stg_noDuplicatezh();
1937 }
1938
1939 stg_noDuplicatezh /* no arg list: explicit stack layout */
1940 {
1941     STK_CHK(WDS(1), stg_noDuplicatezh);
1942
1943     // leave noDuplicate frame in case the current
1944     // computation is suspended and restarted (see above).
1945     Sp_adj(-1);
1946     Sp(0) = stg_noDuplicate_info;
1947
1948     SAVE_THREAD_STATE();
1949     ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
1950     ccall threadPaused (MyCapability() "ptr", CurrentTSO "ptr");
1951
1952     if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
1953         jump stg_threadFinished [];
1954     } else {
1955         LOAD_THREAD_STATE();
1956         ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
1957         // remove the stg_noDuplicate frame if it is still there.
1958         if (Sp(0) == stg_noDuplicate_info) {
1959             Sp_adj(1);
1960         }
1961         jump %ENTRY_CODE(Sp(0)) [];
1962     }
1963 }
1964
1965 /* -----------------------------------------------------------------------------
1966    Misc. primitives
1967    -------------------------------------------------------------------------- */
1968
1969 stg_getApStackValzh ( P_ ap_stack, W_ offset )
1970 {
1971    if (%INFO_PTR(ap_stack) == stg_AP_STACK_info) {
1972        return (1,StgAP_STACK_payload(ap_stack,offset));
1973    } else {
1974        return (0,ap_stack);
1975    }
1976 }
1977
1978 // Write the cost center stack of the first argument on stderr; return
1979 // the second.  Possibly only makes sense for already evaluated
1980 // things?
1981 stg_traceCcszh ( P_ obj, P_ ret )
1982 {
1983     W_ ccs;
1984
1985 #ifdef PROFILING
1986     ccs = StgHeader_ccs(UNTAG(obj));
1987     ccall fprintCCS_stderr(ccs "ptr");
1988 #endif
1989
1990     jump stg_ap_0_fast(ret);
1991 }
1992
1993 stg_getSparkzh ()
1994 {
1995    W_ spark;
1996
1997 #ifndef THREADED_RTS
1998    return (0,ghczmprim_GHCziTypes_False_closure);
1999 #else
2000    (spark) = ccall findSpark(MyCapability());
2001    if (spark != 0) {
2002       return (1,spark);
2003    } else {
2004       return (0,ghczmprim_GHCziTypes_False_closure);
2005    }
2006 #endif
2007 }
2008
2009 stg_numSparkszh ()
2010 {
2011   W_ n;
2012 #ifdef THREADED_RTS
2013   (n) = ccall dequeElements(Capability_sparks(MyCapability()));
2014 #else
2015   n = 0;
2016 #endif
2017   return (n);
2018 }
2019
2020 stg_traceEventzh ( W_ msg )
2021 {
2022 #if defined(TRACING) || defined(DEBUG)
2023
2024    ccall traceUserMsg(MyCapability() "ptr", msg "ptr");
2025
2026 #elif defined(DTRACE)
2027
2028    W_ enabled;
2029
2030    // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
2031    // RtsProbes.h, but that header file includes unistd.h, which doesn't
2032    // work in Cmm
2033 #if !defined(solaris2_TARGET_OS)
2034    (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__msg$v1();
2035 #else
2036    // Solaris' DTrace can't handle the
2037    //     __dtrace_isenabled$HaskellEvent$user__msg$v1
2038    // call above. This call is just for testing whether the user__msg
2039    // probe is enabled, and is here for just performance optimization.
2040    // Since preparation for the probe is not that complex I disable usage of
2041    // this test above for Solaris and enable the probe usage manually
2042    // here. Please note that this does not mean that the probe will be
2043    // used during the runtime! You still need to enable it by consumption
2044    // in your dtrace script as you do with any other probe.
2045    enabled = 1;
2046 #endif
2047    if (enabled != 0) {
2048      ccall dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr");
2049    }
2050
2051 #endif
2052    return ();
2053 }
2054
2055 // Same code as stg_traceEventzh above but a different kind of event
2056 // Before changing this code, read the comments in the impl above
2057 stg_traceMarkerzh ( W_ msg )
2058 {
2059 #if defined(TRACING) || defined(DEBUG)
2060
2061    ccall traceUserMarker(MyCapability() "ptr", msg "ptr");
2062
2063 #elif defined(DTRACE)
2064
2065    W_ enabled;
2066
2067 #if !defined(solaris2_TARGET_OS)
2068    (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__marker$v1();
2069 #else
2070    enabled = 1;
2071 #endif
2072    if (enabled != 0) {
2073      ccall dtraceUserMarkerWrapper(MyCapability() "ptr", msg "ptr");
2074    }
2075
2076 #endif
2077    return ();
2078 }
2079