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