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