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