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