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