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