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