[project @ 2002-10-18 09:51:03 by simonmar]

Add atomicModifyIORef, as discussed on the FFI list.

diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp
index ade88b4..59d6dae 100644 (file)
--- a/ghc/compiler/prelude/primops.txt.pp
+++ b/ghc/compiler/prelude/primops.txt.pp
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.21 2002/06/26 08:18:38 stolz Exp $
+-- $Id: primops.txt.pp,v 1.22 2002/10/18 09:51:04 simonmar Exp $
 --
 -- Primitive Operations
 --
@@ -1274,6 +1274,18 @@ primop  SameMutVarOp "sameMutVar#" GenPrimOp
    with
    usage = { mangle SameMutVarOp [mkP, mkP] mkM }
 
+-- not really the right type, but we don't know about pairs here.  The
+-- correct type is
+--
+--   MutVar# s a -> (a -> (a,b)) -> State# s -> (# State# s, b #)
+--
+primop  AtomicModifyMutVarOp "atomicModifyMutVar#" GenPrimOp
+   MutVar# s a -> (a -> b) -> State# s -> (# State# s, c #)
+   with
+   usage = { mangle AtomicModifyMutVarOp [mkP, mkM, mkP] mkM }
+   has_side_effects = True
+   out_of_line = True
+
 ------------------------------------------------------------------------
 section "Exceptions"
 ------------------------------------------------------------------------

diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h
index ce4917d..a43105e 100644 (file)
--- a/ghc/includes/PrimOps.h
+++ b/ghc/includes/PrimOps.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.97 2002/09/06 14:34:14 simonmar Exp $
+ * $Id: PrimOps.h,v 1.98 2002/10/18 09:51:04 simonmar Exp $
  *
  * (c) The GHC Team, 1998-2000
  *
@@ -218,7 +218,7 @@ extern StgInt    isFloatNegativeZero(StgFloat f);
    -------------------------------------------------------------------------- */
 
 EXTFUN_RTS(newMutVarzh_fast);
-
+EXTFUN_RTS(atomicModifyMutVarzh_fast);
 
 /* -----------------------------------------------------------------------------
    MVar PrimOps.

diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index 0196e21..9320708 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.101 2002/10/18 09:51:03 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
    -------------------------------------------------------------------------- */