37eee439ac8a0c721f78a15848ebc21bc8878628
[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 defined(MIN_UPD_SIZE) && 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 defined(MIN_UPD_SIZE) && 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.cmm.
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    Bytecode object primitives
1929    -------------------------------------------------------------------------  */
1930
1931 stg_newBCOzh ( P_ instrs,
1932                P_ literals,
1933                P_ ptrs,
1934                W_ arity,
1935                P_ bitmap_arr )
1936 {
1937     W_ bco, bytes, words;
1938
1939     words = BYTES_TO_WDS(SIZEOF_StgBCO) + BYTE_ARR_WDS(bitmap_arr);
1940     bytes = WDS(words);
1941
1942     ALLOC_PRIM (bytes);
1943
1944     bco = Hp - bytes + WDS(1);
1945     SET_HDR(bco, stg_BCO_info, CCS_MAIN);
1946
1947     StgBCO_instrs(bco)     = instrs;
1948     StgBCO_literals(bco)   = literals;
1949     StgBCO_ptrs(bco)       = ptrs;
1950     StgBCO_arity(bco)      = HALF_W_(arity);
1951     StgBCO_size(bco)       = HALF_W_(words);
1952
1953     // Copy the arity/bitmap info into the BCO
1954     W_ i;
1955     i = 0;
1956 for:
1957     if (i < BYTE_ARR_WDS(bitmap_arr)) {
1958         StgBCO_bitmap(bco,i) = StgArrBytes_payload(bitmap_arr,i);
1959         i = i + 1;
1960         goto for;
1961     }
1962
1963     return (bco);
1964 }
1965
1966 stg_mkApUpd0zh ( P_ bco )
1967 {
1968     W_ ap;
1969
1970     // This function is *only* used to wrap zero-arity BCOs in an
1971     // updatable wrapper (see ByteCodeLink.hs).  An AP thunk is always
1972     // saturated and always points directly to a FUN or BCO.
1973     ASSERT(%INFO_TYPE(%GET_STD_INFO(bco)) == HALF_W_(BCO) &&
1974            StgBCO_arity(bco) == HALF_W_(0));
1975
1976     HP_CHK_P(SIZEOF_StgAP, stg_mkApUpd0zh, bco);
1977     TICK_ALLOC_UP_THK(0, 0);
1978     CCCS_ALLOC(SIZEOF_StgAP);
1979
1980     ap = Hp - SIZEOF_StgAP + WDS(1);
1981     SET_HDR(ap, stg_AP_info, CCS_MAIN);
1982
1983     StgAP_n_args(ap) = HALF_W_(0);
1984     StgAP_fun(ap) = bco;
1985
1986     return (ap);
1987 }
1988
1989 stg_unpackClosurezh ( P_ closure )
1990 {
1991     W_ clos, info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
1992     clos  = UNTAG(closure);
1993     info  = %GET_STD_INFO(clos);
1994
1995     // Some closures have non-standard layout, so we omit those here.
1996     W_ type;
1997     type = TO_W_(%INFO_TYPE(info));
1998     switch [0 .. N_CLOSURE_TYPES] type {
1999     case THUNK_SELECTOR : {
2000         ptrs = 1;
2001         nptrs = 0;
2002         goto out;
2003     }
2004     case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,
2005          THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
2006         ptrs = 0;
2007         nptrs = 0;
2008         goto out;
2009     }
2010     default: {
2011         ptrs  = TO_W_(%INFO_PTRS(info));
2012         nptrs = TO_W_(%INFO_NPTRS(info));
2013         goto out;
2014     }}
2015
2016 out:
2017     W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
2018     nptrs_arr_sz = SIZEOF_StgArrBytes   + WDS(nptrs);
2019     ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
2020     ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
2021
2022     ALLOC_PRIM_P (ptrs_arr_sz + nptrs_arr_sz, stg_unpackClosurezh, closure);
2023
2024     ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
2025     nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
2026
2027     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);
2028     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
2029     StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
2030
2031     p = 0;
2032
2033 write_ptrs:
2034     if(p < ptrs) {
2035          W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
2036          p = p + 1;
2037          goto write_ptrs;
2038     }
2039     /* We can leave the card table uninitialised, since the array is
2040        allocated in the nursery.  The GC will fill it in if/when the array
2041        is promoted. */
2042
2043     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS);
2044     StgArrBytes_bytes(nptrs_arr) = WDS(nptrs);
2045     p = 0;
2046
2047 write_nptrs:
2048     if(p < nptrs) {
2049          W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
2050          p = p + 1;
2051          goto write_nptrs;
2052     }
2053
2054     return (info, ptrs_arr, nptrs_arr);
2055 }
2056
2057 /* -----------------------------------------------------------------------------
2058    Thread I/O blocking primitives
2059    -------------------------------------------------------------------------- */
2060
2061 /* Add a thread to the end of the blocked queue. (C-- version of the C
2062  * macro in Schedule.h).
2063  */
2064 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
2065     ASSERT(StgTSO__link(tso) == END_TSO_QUEUE);         \
2066     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
2067         W_[blocked_queue_hd] = tso;                     \
2068     } else {                                            \
2069         ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \
2070     }                                                   \
2071     W_[blocked_queue_tl] = tso;
2072
2073 stg_waitReadzh ( W_ fd )
2074 {
2075 #ifdef THREADED_RTS
2076     ccall barf("waitRead# on threaded RTS") never returns;
2077 #else
2078
2079     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2080     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
2081     StgTSO_block_info(CurrentTSO) = fd;
2082     // No locking - we're not going to use this interface in the
2083     // threaded RTS anyway.
2084     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2085     jump stg_block_noregs();
2086 #endif
2087 }
2088
2089 stg_waitWritezh ( W_ fd )
2090 {
2091 #ifdef THREADED_RTS
2092     ccall barf("waitWrite# on threaded RTS") never returns;
2093 #else
2094
2095     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2096     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
2097     StgTSO_block_info(CurrentTSO) = fd;
2098     // No locking - we're not going to use this interface in the
2099     // threaded RTS anyway.
2100     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2101     jump stg_block_noregs();
2102 #endif
2103 }
2104
2105
2106 STRING(stg_delayzh_malloc_str, "stg_delayzh")
2107 stg_delayzh ( W_ us_delay )
2108 {
2109 #ifdef mingw32_HOST_OS
2110     W_ ares;
2111     CInt reqID;
2112 #else
2113     W_ t, prev, target;
2114 #endif
2115
2116 #ifdef THREADED_RTS
2117     ccall barf("delay# on threaded RTS") never returns;
2118 #else
2119
2120     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2121     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
2122
2123 #ifdef mingw32_HOST_OS
2124
2125     /* could probably allocate this on the heap instead */
2126     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
2127                                         stg_delayzh_malloc_str);
2128     (reqID) = ccall addDelayRequest(us_delay);
2129     StgAsyncIOResult_reqID(ares)   = reqID;
2130     StgAsyncIOResult_len(ares)     = 0;
2131     StgAsyncIOResult_errCode(ares) = 0;
2132     StgTSO_block_info(CurrentTSO)  = ares;
2133
2134     /* Having all async-blocked threads reside on the blocked_queue
2135      * simplifies matters, so change the status to OnDoProc put the
2136      * delayed thread on the blocked_queue.
2137      */
2138     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
2139     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2140     jump stg_block_async_void();
2141
2142 #else
2143
2144
2145     (target) = ccall getDelayTarget(us_delay);
2146
2147     StgTSO_block_info(CurrentTSO) = target;
2148
2149     /* Insert the new thread in the sleeping queue. */
2150     prev = NULL;
2151     t = W_[sleeping_queue];
2152 while:
2153     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
2154         prev = t;
2155         t = StgTSO__link(t);
2156         goto while;
2157     }
2158
2159     StgTSO__link(CurrentTSO) = t;
2160     if (prev == NULL) {
2161         W_[sleeping_queue] = CurrentTSO;
2162     } else {
2163         ccall setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO);
2164     }
2165     jump stg_block_noregs();
2166 #endif
2167 #endif /* !THREADED_RTS */
2168 }
2169
2170
2171 #ifdef mingw32_HOST_OS
2172 STRING(stg_asyncReadzh_malloc_str, "stg_asyncReadzh")
2173 stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf )
2174 {
2175     W_ ares;
2176     CInt reqID;
2177
2178 #ifdef THREADED_RTS
2179     ccall barf("asyncRead# on threaded RTS") never returns;
2180 #else
2181
2182     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2183     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
2184
2185     /* could probably allocate this on the heap instead */
2186     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
2187                                         stg_asyncReadzh_malloc_str);
2188     (reqID) = ccall addIORequest(fd, 0/*FALSE*/,is_sock,len,buf "ptr");
2189     StgAsyncIOResult_reqID(ares)   = reqID;
2190     StgAsyncIOResult_len(ares)     = 0;
2191     StgAsyncIOResult_errCode(ares) = 0;
2192     StgTSO_block_info(CurrentTSO)  = ares;
2193     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2194     jump stg_block_async();
2195 #endif
2196 }
2197
2198 STRING(stg_asyncWritezh_malloc_str, "stg_asyncWritezh")
2199 stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf )
2200 {
2201     W_ ares;
2202     CInt reqID;
2203
2204 #ifdef THREADED_RTS
2205     ccall barf("asyncWrite# on threaded RTS") never returns;
2206 #else
2207
2208     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2209     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
2210
2211     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
2212                                         stg_asyncWritezh_malloc_str);
2213     (reqID) = ccall addIORequest(fd, 1/*TRUE*/,is_sock,len,buf "ptr");
2214
2215     StgAsyncIOResult_reqID(ares)   = reqID;
2216     StgAsyncIOResult_len(ares)     = 0;
2217     StgAsyncIOResult_errCode(ares) = 0;
2218     StgTSO_block_info(CurrentTSO)  = ares;
2219     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2220     jump stg_block_async();
2221 #endif
2222 }
2223
2224 STRING(stg_asyncDoProczh_malloc_str, "stg_asyncDoProczh")
2225 stg_asyncDoProczh ( W_ proc, W_ param )
2226 {
2227     W_ ares;
2228     CInt reqID;
2229
2230 #ifdef THREADED_RTS
2231     ccall barf("asyncDoProc# on threaded RTS") never returns;
2232 #else
2233
2234     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2235     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
2236
2237     /* could probably allocate this on the heap instead */
2238     ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
2239                                         stg_asyncDoProczh_malloc_str);
2240     (reqID) = ccall addDoProcRequest(proc "ptr",param "ptr");
2241     StgAsyncIOResult_reqID(ares)   = reqID;
2242     StgAsyncIOResult_len(ares)     = 0;
2243     StgAsyncIOResult_errCode(ares) = 0;
2244     StgTSO_block_info(CurrentTSO) = ares;
2245     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2246     jump stg_block_async();
2247 #endif
2248 }
2249 #endif
2250
2251 /* -----------------------------------------------------------------------------
2252  * noDuplicate#
2253  *
2254  * noDuplicate# tries to ensure that none of the thunks under
2255  * evaluation by the current thread are also under evaluation by
2256  * another thread.  It relies on *both* threads doing noDuplicate#;
2257  * the second one will get blocked if they are duplicating some work.
2258  *
2259  * The idea is that noDuplicate# is used within unsafePerformIO to
2260  * ensure that the IO operation is performed at most once.
2261  * noDuplicate# calls threadPaused which acquires an exclusive lock on
2262  * all the thunks currently under evaluation by the current thread.
2263  *
2264  * Consider the following scenario.  There is a thunk A, whose
2265  * evaluation requires evaluating thunk B, where thunk B is an
2266  * unsafePerformIO.  Two threads, 1 and 2, bother enter A.  Thread 2
2267  * is pre-empted before it enters B, and claims A by blackholing it
2268  * (in threadPaused).  Thread 1 now enters B, and calls noDuplicate#.
2269  *
2270  *      thread 1                      thread 2
2271  *   +-----------+                 +---------------+
2272  *   |    -------+-----> A <-------+-------        |
2273  *   |  update   |   BLACKHOLE     | marked_update |
2274  *   +-----------+                 +---------------+
2275  *   |           |                 |               |
2276  *        ...                             ...
2277  *   |           |                 +---------------+
2278  *   +-----------+
2279  *   |     ------+-----> B
2280  *   |  update   |   BLACKHOLE
2281  *   +-----------+
2282  *
2283  * At this point: A is a blackhole, owned by thread 2.  noDuplicate#
2284  * calls threadPaused, which walks up the stack and
2285  *  - claims B on behalf of thread 1
2286  *  - then it reaches the update frame for A, which it sees is already
2287  *    a BLACKHOLE and is therefore owned by another thread.  Since
2288  *    thread 1 is duplicating work, the computation up to the update
2289  *    frame for A is suspended, including thunk B.
2290  *  - thunk B, which is an unsafePerformIO, has now been reverted to
2291  *    an AP_STACK which could be duplicated - BAD!
2292  *  - The solution is as follows: before calling threadPaused, we
2293  *    leave a frame on the stack (stg_noDuplicate_info) that will call
2294  *    noDuplicate# again if the current computation is suspended and
2295  *    restarted.
2296  *
2297  * See the test program in concurrent/prog003 for a way to demonstrate
2298  * this.  It needs to be run with +RTS -N3 or greater, and the bug
2299  * only manifests occasionally (once very 10 runs or so).
2300  * -------------------------------------------------------------------------- */
2301
2302 INFO_TABLE_RET(stg_noDuplicate, RET_SMALL, W_ info_ptr)
2303     return (/* no return values */)
2304 {
2305     jump stg_noDuplicatezh();
2306 }
2307
2308 stg_noDuplicatezh /* no arg list: explicit stack layout */
2309 {
2310     // With a single capability there's no chance of work duplication.
2311     if (CInt[n_capabilities] == 1 :: CInt) {
2312         jump %ENTRY_CODE(Sp(0)) [];
2313     }
2314
2315     STK_CHK_LL (WDS(1), stg_noDuplicatezh);
2316
2317     // leave noDuplicate frame in case the current
2318     // computation is suspended and restarted (see above).
2319     Sp_adj(-1);
2320     Sp(0) = stg_noDuplicate_info;
2321
2322     SAVE_THREAD_STATE();
2323     ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
2324     ccall threadPaused (MyCapability() "ptr", CurrentTSO "ptr");
2325
2326     if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
2327         jump stg_threadFinished [];
2328     } else {
2329         LOAD_THREAD_STATE();
2330         ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
2331         // remove the stg_noDuplicate frame if it is still there.
2332         if (Sp(0) == stg_noDuplicate_info) {
2333             Sp_adj(1);
2334         }
2335         jump %ENTRY_CODE(Sp(0)) [];
2336     }
2337 }
2338
2339 /* -----------------------------------------------------------------------------
2340    Misc. primitives
2341    -------------------------------------------------------------------------- */
2342
2343 stg_getApStackValzh ( P_ ap_stack, W_ offset )
2344 {
2345    if (%INFO_PTR(ap_stack) == stg_AP_STACK_info) {
2346        return (1,StgAP_STACK_payload(ap_stack,offset));
2347    } else {
2348        return (0,ap_stack);
2349    }
2350 }
2351
2352 // Write the cost center stack of the first argument on stderr; return
2353 // the second.  Possibly only makes sense for already evaluated
2354 // things?
2355 stg_traceCcszh ( P_ obj, P_ ret )
2356 {
2357     W_ ccs;
2358
2359 #ifdef PROFILING
2360     ccs = StgHeader_ccs(UNTAG(obj));
2361     ccall fprintCCS_stderr(ccs "ptr");
2362 #endif
2363
2364     jump stg_ap_0_fast(ret);
2365 }
2366
2367 stg_getSparkzh ()
2368 {
2369     W_ spark;
2370
2371 #ifndef THREADED_RTS
2372     return (0,ghczmprim_GHCziTypes_False_closure);
2373 #else
2374     ("ptr" spark) = ccall findSpark(MyCapability() "ptr");
2375     if (spark != 0) {
2376         return (1,spark);
2377     } else {
2378         return (0,ghczmprim_GHCziTypes_False_closure);
2379     }
2380 #endif
2381 }
2382
2383 stg_clearCCSzh (P_ arg)
2384 {
2385 #ifdef PROFILING
2386     CCCS = CCS_MAIN;
2387 #endif
2388     jump stg_ap_v_fast(arg);
2389 }
2390
2391 stg_numSparkszh ()
2392 {
2393     W_ n;
2394 #ifdef THREADED_RTS
2395     (n) = ccall dequeElements(Capability_sparks(MyCapability()));
2396 #else
2397     n = 0;
2398 #endif
2399     return (n);
2400 }
2401
2402 stg_traceEventzh ( W_ msg )
2403 {
2404 #if defined(TRACING) || defined(DEBUG)
2405
2406     ccall traceUserMsg(MyCapability() "ptr", msg "ptr");
2407
2408 #elif defined(DTRACE)
2409
2410     W_ enabled;
2411
2412     // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
2413     // RtsProbes.h, but that header file includes unistd.h, which doesn't
2414     // work in Cmm
2415 #if !defined(solaris2_TARGET_OS)
2416    (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__msg$v1();
2417 #else
2418     // Solaris' DTrace can't handle the
2419     //     __dtrace_isenabled$HaskellEvent$user__msg$v1
2420     // call above. This call is just for testing whether the user__msg
2421     // probe is enabled, and is here for just performance optimization.
2422     // Since preparation for the probe is not that complex I disable usage of
2423     // this test above for Solaris and enable the probe usage manually
2424     // here. Please note that this does not mean that the probe will be
2425     // used during the runtime! You still need to enable it by consumption
2426     // in your dtrace script as you do with any other probe.
2427     enabled = 1;
2428 #endif
2429     if (enabled != 0) {
2430       ccall dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr");
2431     }
2432
2433 #endif
2434     return ();
2435 }
2436
2437 // Same code as stg_traceEventzh above but a different kind of event
2438 // Before changing this code, read the comments in the impl above
2439 stg_traceMarkerzh ( W_ msg )
2440 {
2441 #if defined(TRACING) || defined(DEBUG)
2442
2443     ccall traceUserMarker(MyCapability() "ptr", msg "ptr");
2444
2445 #elif defined(DTRACE)
2446
2447     W_ enabled;
2448
2449 #if !defined(solaris2_TARGET_OS)
2450     (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__marker$v1();
2451 #else
2452     enabled = 1;
2453 #endif
2454     if (enabled != 0) {
2455         ccall dtraceUserMarkerWrapper(MyCapability() "ptr", msg "ptr");
2456     }
2457
2458 #endif
2459     return ();
2460 }
2461