Export blockUserSignals and unblockUserSignals (needed for #2870)

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

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index f75b8aa..cd9a5bf 100644 (file)
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -91,24 +91,17 @@ newPinnedByteArrayzh_fast
     n = R1;
     payload_words = ROUNDUP_BYTES_TO_WDS(n);
 
-    // We want an 8-byte aligned array.  allocatePinned() gives us
+    // We want a 16-byte aligned array.  allocatePinned() gives us
     // 8-byte aligned memory by default, but we want to align the
     // *goods* inside the ArrWords object, so we have to check the
     // size of the ArrWords header and adjust our size accordingly.
-    words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
-    if ((SIZEOF_StgArrWords & 7) != 0) {
-       words = words + 1;
-    }
+    words = payload_words + ((SIZEOF_StgArrWords + 15) & ~15);
 
     ("ptr" p) = foreign "C" allocatePinned(words) [];
     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
 
-    // Again, if the ArrWords header isn't a multiple of 8 bytes, we
-    // have to push the object forward one word so that the goods
-    // fall on an 8-byte boundary.
-    if ((SIZEOF_StgArrWords & 7) != 0) {
-       p = p + WDS(1);
-    }
+    // Push the pointer forward so that the goods fall on a 16-byte boundary.
+    p = p + ((p + SIZEOF_StgArrWords) & 15);
 
     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
     StgArrWords_words(p) = payload_words;
@@ -297,9 +290,14 @@ mkWeakzh_fast
   w = Hp - SIZEOF_StgWeak + WDS(1);
   SET_HDR(w, stg_WEAK_info, W_[CCCS]);
 
-  StgWeak_key(w)       = R1;
-  StgWeak_value(w)     = R2;
-  StgWeak_finalizer(w) = R3;
+  // We don't care about cfinalizer here.
+  // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or
+  // something else?
+
+  StgWeak_key(w)        = R1;
+  StgWeak_value(w)      = R2;
+  StgWeak_finalizer(w)  = R3;
+  StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure;
 
   StgWeak_link(w)      = W_[weak_ptr_list];
   W_[weak_ptr_list]    = w;
@@ -309,12 +307,65 @@ mkWeakzh_fast
   RET_P(w);
 }
 
+mkWeakForeignEnvzh_fast
+{
+  /* R1 = key
+     R2 = value
+     R3 = finalizer
+     R4 = pointer
+     R5 = has environment (0 or 1)
+     R6 = environment
+  */
+  W_ w, payload_words, words, p;
+
+  W_ key, val, fptr, ptr, flag, eptr;
+
+  key  = R1;
+  val  = R2;
+  fptr = R3;
+  ptr  = R4;
+  flag = R5;
+  eptr = R6;
+
+  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, mkWeakForeignEnvzh_fast );
+
+  w = Hp - SIZEOF_StgWeak + WDS(1);
+  SET_HDR(w, stg_WEAK_info, W_[CCCS]);
+
+  payload_words = 4;
+  words         = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
+  ("ptr" p)     = foreign "C" allocateLocal(MyCapability() "ptr", words) [];
+
+  TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+  SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
+
+  StgArrWords_words(p)     = payload_words;
+  StgArrWords_payload(p,0) = fptr;
+  StgArrWords_payload(p,1) = ptr;
+  StgArrWords_payload(p,2) = eptr;
+  StgArrWords_payload(p,3) = flag;
+
+  // We don't care about the value here.
+  // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else?
+
+  StgWeak_key(w)        = key;
+  StgWeak_value(w)      = val;
+  StgWeak_finalizer(w)  = stg_NO_FINALIZER_closure;
+  StgWeak_cfinalizer(w) = p;
+
+  StgWeak_link(w)   = W_[weak_ptr_list];
+  W_[weak_ptr_list] = w;
+
+  IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
+
+  RET_P(w);
+}
 
 finalizzeWeakzh_fast
 {
   /* R1 = weak ptr
    */
-  W_ w, f;
+  W_ w, f, arr;
 
   w = R1;
 
@@ -342,9 +393,18 @@ finalizzeWeakzh_fast
   SET_INFO(w,stg_DEAD_WEAK_info);
   LDV_RECORD_CREATE(w);
 
-  f = StgWeak_finalizer(w);
+  f   = StgWeak_finalizer(w);
+  arr = StgWeak_cfinalizer(w);
+
   StgDeadWeak_link(w) = StgWeak_link(w);
 
+  if (arr != stg_NO_FINALIZER_closure) {
+    foreign "C" runCFinalizer(StgArrWords_payload(arr,0),
+                              StgArrWords_payload(arr,1),
+                              StgArrWords_payload(arr,2),
+                              StgArrWords_payload(arr,3)) [];
+  }
+
   /* return the finalizer */
   if (f == stg_NO_FINALIZER_closure) {
       RET_NP(0,stg_NO_FINALIZER_closure);
@@ -1584,8 +1644,11 @@ takeMVarzh_fast
                                    CurrentTSO) [];
        }
        StgTSO__link(CurrentTSO)       = stg_END_TSO_QUEUE_closure;
-       StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
        StgTSO_block_info(CurrentTSO)  = mvar;
+        // write barrier for throwTo(), which looks at block_info
+        // if why_blocked==BlockedOnMVar.
+        prim %write_barrier() [];
+       StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
        StgMVar_tail(mvar) = CurrentTSO;
        
         R1 = mvar;
@@ -1741,8 +1804,11 @@ putMVarzh_fast
                                    CurrentTSO) [];
        }
        StgTSO__link(CurrentTSO)       = stg_END_TSO_QUEUE_closure;
-       StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
        StgTSO_block_info(CurrentTSO)  = mvar;
+        // write barrier for throwTo(), which looks at block_info
+        // if why_blocked==BlockedOnMVar.
+        prim %write_barrier() [];
+       StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
        StgMVar_tail(mvar) = CurrentTSO;
        
         R1 = mvar;
@@ -2289,6 +2355,26 @@ getApStackValzh_fast
    RET_NP(ok,val);
 }
 
+/* -----------------------------------------------------------------------------
+   Misc. primitives
+   -------------------------------------------------------------------------- */
+
+// Write the cost center stack of the first argument on stderr; return
+// the second.  Possibly only makes sense for already evaluated
+// things?
+traceCcszh_fast
+{
+    W_ ccs;
+
+#ifdef PROFILING
+    ccs = StgHeader_ccs(UNTAG(R1));
+    foreign "C" fprintCCS_stderr(ccs "ptr") [R2];
+#endif
+
+    R1 = R2;
+    ENTER();
+}
+
 getSparkzh_fast
 {
    W_ spark;