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