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