X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FPrimOps.cmm;h=6c3593e4a485a97306735ffdd8421db8dc51a359;hb=9d03becc597e5b1ab6c8466209a1263bf8ba6f29;hp=9f05a038c8f3f3a22fe5d224362a1a0f6571bb7e;hpb=82f8341d3d87d9127c968baa9c3376e3f26caa81;p=ghc-hetmet.git

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 9f05a03..6c3593e 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -27,6 +27,8 @@
 
 #include "Cmm.h"
 
+#ifdef __PIC__
+#ifndef mingw32_HOST_OS
 import __gmpz_init;
 import __gmpz_add;
 import __gmpz_sub;
@@ -43,9 +45,13 @@ import __gmpz_and;
 import __gmpz_xor;
 import __gmpz_ior;
 import __gmpz_com;
-import base_GHCziIOBase_NestedAtomically_closure;
+#endif
 import pthread_mutex_lock;
 import pthread_mutex_unlock;
+#endif
+import base_GHCziIOBase_NestedAtomically_closure;
+import EnterCriticalSection;
+import LeaveCriticalSection;
 
 /*-----------------------------------------------------------------------------
   Array Primitives
@@ -227,7 +233,7 @@ atomicModifyMutVarzh_fast
    HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, atomicModifyMutVarzh_fast);
 
 #if defined(THREADED_RTS)
-    foreign "C" ACQUIRE_LOCK(atomic_modify_mutvar_mutex "ptr") [R1,R2];
+    ACQUIRE_LOCK(atomic_modify_mutvar_mutex "ptr") [R1,R2];
 #endif
 
    x = StgMutVar_var(R1);
@@ -258,7 +264,7 @@ atomicModifyMutVarzh_fast
    StgThunk_payload(r,0) = z;
 
 #if defined(THREADED_RTS)
-    foreign "C" RELEASE_LOCK(atomic_modify_mutvar_mutex "ptr") [];
+    RELEASE_LOCK(atomic_modify_mutvar_mutex "ptr") [];
 #endif
 
    RET_P(r);
@@ -446,11 +452,11 @@ int64ToIntegerzh_fast
    hi = TO_W_(val >> 32);
    lo = TO_W_(val);
 
-   if ( hi != 0 && hi != 0xFFFFFFFF )  { 
-       words_needed = 2;
-   } else { 
+   if ( hi == 0 || (hi == 0xFFFFFFFF && lo != 0) )  {
        // minimum is one word
        words_needed = 1;
+   } else { 
+       words_needed = 2;
    }
 
    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
@@ -870,6 +876,23 @@ decodeFloatzh_fast
     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
 }
 
+decodeFloatzuIntzh_fast
+{ 
+    W_ p;
+    F_ arg;
+    FETCH_MP_TEMP(mp_tmp1);
+    FETCH_MP_TEMP(mp_tmp_w);
+    
+    /* arguments: F1 = Float# */
+    arg = F1;
+    
+    /* Perform the operation */
+    foreign "C" __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg) [];
+    
+    /* returns: (Int# (mantissa), Int# (exponent)) */
+    RET_NN(W_[mp_tmp1], W_[mp_tmp_w]);
+}
+
 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
 
@@ -899,6 +922,24 @@ decodeDoublezh_fast
     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
 }
 
+decodeDoublezu2Intzh_fast
+{ 
+    D_ arg;
+    W_ p;
+    FETCH_MP_TEMP(mp_tmp1);
+    FETCH_MP_TEMP(mp_tmp2);
+    FETCH_MP_TEMP(mp_tmp_w);
+
+    /* arguments: D1 = Double# */
+    arg = D1;
+
+    /* Perform the operation */
+    foreign "C" __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr", mp_tmp_w "ptr", arg) [];
+    
+    /* returns: (Int# (mant high), Int# (mant low), Int# (expn)) */
+    RET_NNN(W_[mp_tmp1], W_[mp_tmp2], W_[mp_tmp_w]);
+}
+
 /* -----------------------------------------------------------------------------
  * Concurrency primitives
  * -------------------------------------------------------------------------- */
@@ -916,6 +957,12 @@ forkzh_fast
   ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", 
 				RtsFlags_GcFlags_initialStkSize(RtsFlags), 
 				closure "ptr") [];
+
+  /* start blocked if the current thread is blocked */
+  StgTSO_flags(threadid) = 
+     StgTSO_flags(threadid) |  (StgTSO_flags(CurrentTSO) & 
+                                (TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32));
+
   foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];
 
   // switch at the earliest opportunity
@@ -939,6 +986,12 @@ forkOnzh_fast
   ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", 
 				RtsFlags_GcFlags_initialStkSize(RtsFlags), 
 				closure "ptr") [];
+
+  /* start blocked if the current thread is blocked */
+  StgTSO_flags(threadid) = 
+     StgTSO_flags(threadid) |  (StgTSO_flags(CurrentTSO) & 
+                                (TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32));
+
   foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
 
   // switch at the earliest opportunity
@@ -1441,7 +1494,7 @@ isEmptyMVarzh_fast
 {
     /* args: R1 = MVar closure */
 
-    if (GET_INFO(R1) == stg_EMPTY_MVAR_info) {
+    if (StgMVar_value(R1) == stg_END_TSO_QUEUE_closure) {
 	RET_N(1);
     } else {
 	RET_N(0);
@@ -1456,7 +1509,8 @@ newMVarzh_fast
     ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
   
     mvar = Hp - SIZEOF_StgMVar + WDS(1);
-    SET_HDR(mvar,stg_EMPTY_MVAR_info,W_[CCCS]);
+    SET_HDR(mvar,stg_MVAR_DIRTY_info,W_[CCCS]);
+        // MVARs start dirty: generation 0 has no mutable list
     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
@@ -1491,11 +1545,15 @@ takeMVarzh_fast
 #else
     info = GET_INFO(mvar);
 #endif
+        
+    if (info == stg_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
 
     /* If the MVar is empty, put ourselves on its blocking queue,
      * and wait until we're woken up.
      */
-    if (info == stg_EMPTY_MVAR_info) {
+    if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 	    StgMVar_head(mvar) = CurrentTSO;
 	} else {
@@ -1539,7 +1597,9 @@ takeMVarzh_fast
       }
 
 #if defined(THREADED_RTS)
-      unlockClosure(mvar, stg_FULL_MVAR_info);
+      unlockClosure(mvar, stg_MVAR_DIRTY_info);
+#else
+      SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
       RET_P(val);
   } 
@@ -1549,9 +1609,9 @@ takeMVarzh_fast
       StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
  
 #if defined(THREADED_RTS)
-      unlockClosure(mvar, stg_EMPTY_MVAR_info);
+      unlockClosure(mvar, stg_MVAR_DIRTY_info);
 #else
-      SET_INFO(mvar,stg_EMPTY_MVAR_info);
+      SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
 
       RET_P(val);
@@ -1573,9 +1633,9 @@ tryTakeMVarzh_fast
     info = GET_INFO(mvar);
 #endif
 
-    if (info == stg_EMPTY_MVAR_info) {
+    if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
 #if defined(THREADED_RTS)
-        unlockClosure(mvar, stg_EMPTY_MVAR_info);
+        unlockClosure(mvar, info);
 #endif
 	/* HACK: we need a pointer to pass back, 
 	 * so we abuse NO_FINALIZER_closure
@@ -1583,6 +1643,10 @@ tryTakeMVarzh_fast
 	RET_NP(0, stg_NO_FINALIZER_closure);
     }
 
+    if (info == stg_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
     /* we got the value... */
     val = StgMVar_value(mvar);
 
@@ -1612,7 +1676,9 @@ tryTakeMVarzh_fast
 	    StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
 	}
 #if defined(THREADED_RTS)
-        unlockClosure(mvar, stg_FULL_MVAR_info);
+        unlockClosure(mvar, stg_MVAR_DIRTY_info);
+#else
+        SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
     }
     else 
@@ -1620,9 +1686,9 @@ tryTakeMVarzh_fast
 	/* No further putMVars, MVar is now empty */
 	StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_EMPTY_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
 #else
-	SET_INFO(mvar,stg_EMPTY_MVAR_info);
+	SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
     }
     
@@ -1643,7 +1709,11 @@ putMVarzh_fast
     info = GET_INFO(mvar);
 #endif
 
-    if (info == stg_FULL_MVAR_info) {
+    if (info == stg_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
+    if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 	    StgMVar_head(mvar) = CurrentTSO;
 	} else {
@@ -1682,7 +1752,9 @@ putMVarzh_fast
 	}
 
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_EMPTY_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
+#else
+        SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
 	jump %ENTRY_CODE(Sp(0));
     }
@@ -1692,9 +1764,9 @@ putMVarzh_fast
 	StgMVar_value(mvar) = R2;
 
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_FULL_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
 #else
-	SET_INFO(mvar,stg_FULL_MVAR_info);
+	SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
 	jump %ENTRY_CODE(Sp(0));
     }
@@ -1716,13 +1788,17 @@ tryPutMVarzh_fast
     info = GET_INFO(mvar);
 #endif
 
-    if (info == stg_FULL_MVAR_info) {
+    if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_FULL_MVAR_info);
+    	unlockClosure(mvar, info);
 #endif
 	RET_N(0);
     }
   
+    if (info == stg_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
 
 	/* There are takeMVar(s) waiting: wake up the first one
@@ -1748,7 +1824,9 @@ tryPutMVarzh_fast
 	}
 
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_EMPTY_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
+#else
+        SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
     }
     else
@@ -1757,9 +1835,9 @@ tryPutMVarzh_fast
 	StgMVar_value(mvar) = R2;
 
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_FULL_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
 #else
-	SET_INFO(mvar,stg_FULL_MVAR_info);
+	SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
     }
     
@@ -1967,7 +2045,7 @@ waitReadzh_fast
 {
     /* args: R1 */
 #ifdef THREADED_RTS
-    foreign "C" barf("waitRead# on threaded RTS");
+    foreign "C" barf("waitRead# on threaded RTS") never returns;
 #else
 
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
@@ -1984,7 +2062,7 @@ waitWritezh_fast
 {
     /* args: R1 */
 #ifdef THREADED_RTS
-    foreign "C" barf("waitWrite# on threaded RTS");
+    foreign "C" barf("waitWrite# on threaded RTS") never returns;
 #else
 
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
@@ -2009,7 +2087,7 @@ delayzh_fast
 #endif
 
 #ifdef THREADED_RTS
-    foreign "C" barf("delay# on threaded RTS");
+    foreign "C" barf("delay# on threaded RTS") never returns;
 #else
 
     /* args: R1 (microsecond delay amount) */
@@ -2075,7 +2153,7 @@ asyncReadzh_fast
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncRead# on threaded RTS");
+    foreign "C" barf("asyncRead# on threaded RTS") never returns;
 #else
 
     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
@@ -2103,7 +2181,7 @@ asyncWritezh_fast
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncWrite# on threaded RTS");
+    foreign "C" barf("asyncWrite# on threaded RTS") never returns;
 #else
 
     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
@@ -2131,7 +2209,7 @@ asyncDoProczh_fast
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncDoProc# on threaded RTS");
+    foreign "C" barf("asyncDoProc# on threaded RTS") never returns;
 #else
 
     /* args: R1 = proc, R2 = param */