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