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