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