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