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