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