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