X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2FPrimOps.cmm;h=e17c6fb3f870b7b923c79570cfe45a087bd787ee;hp=4f6c2526d4ecf6c2c7cb5ab3c8e0ec9562769687;hb=e5c3b478b3cd1707cf122833822f44b2ac09b8e9;hpb=f30d527344db528618f64a25250a3be557d9f287

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 4f6c252..e17c6fb 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1,6 +1,6 @@
 /* -----------------------------------------------------------------------------
  *
- * (c) The GHC Team, 1998-2004
+ * (c) The GHC Team, 1998-2011
  *
  * Out-of-line primitive operations
  *
@@ -212,6 +212,7 @@ stg_unsafeThawArrayzh
   }
 }
 
+
 /* -----------------------------------------------------------------------------
    MutVar primitives
    -------------------------------------------------------------------------- */
@@ -230,6 +231,25 @@ stg_newMutVarzh
     RET_P(mv);
 }
 
+stg_casMutVarzh
+ /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, a #) */
+{
+    W_ mv, old, new, h;
+
+    mv  = R1;
+    old = R2;
+    new = R3;
+
+    (h) = foreign "C" cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var,
+                          old, new) [];
+    if (h != old) {
+        RET_NP(1,h);
+    } else {
+        RET_NP(0,h);
+    }
+}
+
+
 stg_atomicModifyMutVarzh
 {
     W_ mv, f, z, x, y, r, h;
@@ -631,7 +651,7 @@ stg_threadStatuszh
     W_ tso;
     W_ why_blocked;
     W_ what_next;
-    W_ ret;
+    W_ ret, cap, locked;
 
     tso = R1;
 
@@ -651,7 +671,16 @@ stg_threadStatuszh
             ret = why_blocked;
         }
     }
-    RET_N(ret);
+
+    cap = TO_W_(Capability_no(StgTSO_cap(tso)));
+
+    if ((TO_W_(StgTSO_flags(tso)) & TSO_LOCKED) != 0) {
+        locked = 1;
+    } else {
+        locked = 0;
+    }
+
+    RET_NNN(ret,cap,locked);
 }
 
 /* -----------------------------------------------------------------------------
@@ -1133,13 +1162,17 @@ stg_newMVarzh
 }
 
 
-#define PerformTake(stack, value)                       \
-    W_[StgStack_sp(stack) + WDS(1)] = value;            \
-    W_[StgStack_sp(stack) + WDS(0)] = stg_gc_unpt_r1_info;
+#define PerformTake(stack, value)               \
+    W_ sp;                                      \
+    sp = StgStack_sp(stack);                    \
+    W_[sp + WDS(1)] = value;                    \
+    W_[sp + WDS(0)] = stg_gc_unpt_r1_info;
 
-#define PerformPut(stack,lval)                      \
-    StgStack_sp(stack) = StgStack_sp(stack) + WDS(3);   \
-    lval = W_[StgStack_sp(stack) - WDS(1)];
+#define PerformPut(stack,lval)                  \
+    W_ sp;                                      \
+    sp = StgStack_sp(stack) + WDS(3);           \
+    StgStack_sp(stack) = sp;                    \
+    lval = W_[sp - WDS(1)];
 
 stg_takeMVarzh
 {
@@ -2031,7 +2064,20 @@ stg_traceEventzh
    // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
    // RtsProbes.h, but that header file includes unistd.h, which doesn't
    // work in Cmm
+#if !defined(solaris2_TARGET_OS)
    (enabled) = foreign "C" __dtrace_isenabled$HaskellEvent$user__msg$v1() [];
+#else
+   // Solaris' DTrace can't handle the
+   //     __dtrace_isenabled$HaskellEvent$user__msg$v1
+   // call above. This call is just for testing whether the user__msg
+   // probe is enabled, and is here for just performance optimization.
+   // Since preparation for the probe is not that complex I disable usage of
+   // this test above for Solaris and enable the probe usage manually
+   // here. Please note that this does not mean that the probe will be
+   // used during the runtime! You still need to enable it by consumption
+   // in your dtrace script as you do with any other probe.
+   enabled = 1;
+#endif
    if (enabled != 0) {
      foreign "C" dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr") [];
    }