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