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