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