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