[project @ 2002-12-05 23:49:43 by mthomas]

[ghc-hetmet.git] / ghc / rts / PrimOps.hc

diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index 0196e21..a860dc8 100644 (file)
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.100 2002/07/17 09:21:50 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.102 2002/10/22 11:01:19 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -350,6 +350,60 @@ FN_(newMutVarzh_fast)
   FE_
 }
 
+FN_(atomicModifyMutVarzh_fast)
+{
+   StgMutVar* mv;
+   StgClosure *z, *x, *y, *r;
+   FB_
+   /* Args: R1.p :: MutVar#,  R2.p :: a -> (a,b) */
+
+   /* If x is the current contents of the MutVar#, then 
+      We want to make the new contents point to
+
+         (sel_0 (f x))
+ 
+      and the return value is
+
+        (sel_1 (f x))
+
+      obviously we can share (f x).
+
+         z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
+        y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
+         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
+   */
+
+#define THUNK_SIZE(n) (sizeofW(StgHeader) + stg_max((n), MIN_UPD_SIZE))
+#define SIZE (THUNK_SIZE(2) + THUNK_SIZE(1) + THUNK_SIZE(1))
+
+   HP_CHK_GEN_TICKY(SIZE, R1_PTR|R2_PTR, atomicModifyMutVarzh_fast,);
+   CCS_ALLOC(CCCS,SIZE);
+
+   x = ((StgMutVar *)R1.cl)->var;
+
+   TICK_ALLOC_UP_THK(2,0); // XXX
+   z = (StgClosure *) Hp - THUNK_SIZE(2) + 1;
+   SET_HDR(z, &stg_ap_2_upd_info, CCCS);
+   z->payload[0] = R2.cl;
+   z->payload[1] = x;
+
+   TICK_ALLOC_UP_THK(1,1); // XXX
+   y = (StgClosure *) (StgPtr)z - THUNK_SIZE(1);
+   SET_HDR(y, &stg_sel_0_upd_info, CCCS);
+   y->payload[0] = z;
+
+   ((StgMutVar *)R1.cl)->var = y;
+
+   TICK_ALLOC_UP_THK(1,1); // XXX
+   r = (StgClosure *) (StgPtr)y - THUNK_SIZE(1);
+   SET_HDR(r, &stg_sel_1_upd_info, CCCS);
+   r->payload[0] = z;
+
+   RET_P(r);
+   JMP_(ENTRY_CODE(Sp[0]));
+   FE_
+}
+
 /* -----------------------------------------------------------------------------
    Foreign Object Primitives
    -------------------------------------------------------------------------- */
@@ -1069,7 +1123,7 @@ FN_(labelThreadzh_fast)
        R1.p = ThreadId#
        R2.p = Addr# */
 #ifdef DEBUG
-  STGCALL2(labelThread,(StgTSO *)R1.p,(char *)R2.p);
+  STGCALL2(labelThread,R1.p,(char *)R2.p);
 #endif
   JMP_(ENTRY_CODE(Sp[0]));
   FE_