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