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