projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Allow "INLINEABLE" as a synonym
[ghc-hetmet.git] / rts / PrimOps.cmm
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 892ef68..1cc9544 100644 (file)
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -64,7 +64,7 @@ stg_newByteArrayzh
     ("ptr" p) = foreign "C" allocate(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_bytes(p) = n;
     RET_P(p);
 }
 
@@ -73,10 +73,11 @@ stg_newByteArrayzh
 
 stg_newPinnedByteArrayzh
 {
-    W_ words, bytes, payload_words, p;
+    W_ words, n, bytes, payload_words, p;
 
     MAYBE_GC(NO_PTRS,stg_newPinnedByteArrayzh);
-    bytes = R1;
+    n = R1;
+    bytes = n;
     /* payload_words is what we will tell the profiler we had to allocate */
     payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
     /* When we actually allocate memory, we need to allow space for the
@@ -96,18 +97,25 @@ stg_newPinnedByteArrayzh
     p = p + ((-p - SIZEOF_StgArrWords) & BA_MASK);
 
     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
-    StgArrWords_words(p) = payload_words;
+    StgArrWords_bytes(p) = n;
     RET_P(p);
 }
 
 stg_newAlignedPinnedByteArrayzh
 {
-    W_ words, bytes, payload_words, p, alignment;
+    W_ words, n, bytes, payload_words, p, alignment;
 
     MAYBE_GC(NO_PTRS,stg_newAlignedPinnedByteArrayzh);
-    bytes = R1;
+    n = R1;
     alignment = R2;
 
+    /* we always supply at least word-aligned memory, so there's no
+       need to allow extra space for alignment if the requirement is less
+       than a word.  This also prevents mischief with alignment == 0. */
+    if (alignment <= SIZEOF_W) { alignment = 1; }
+
+    bytes = n;
+
     /* payload_words is what we will tell the profiler we had to allocate */
     payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
 
@@ -129,7 +137,7 @@ stg_newAlignedPinnedByteArrayzh
     p = p + ((-p - SIZEOF_StgArrWords) & (alignment - 1));
 
     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
-    StgArrWords_words(p) = payload_words;
+    StgArrWords_bytes(p) = n;
     RET_P(p);
 }
 
@@ -378,7 +386,7 @@ stg_mkWeakForeignEnvzh
   TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
   SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 
-  StgArrWords_words(p)     = payload_words;
+  StgArrWords_bytes(p)     = WDS(payload_words);
   StgArrWords_payload(p,0) = fptr;
   StgArrWords_payload(p,1) = ptr;
   StgArrWords_payload(p,2) = eptr;
@@ -1211,22 +1219,29 @@ loop:
     // There are putMVar(s) waiting... wake up the first thread on the queue
     
     tso = StgMVarTSOQueue_tso(q);
-    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
-    ASSERT(StgTSO_block_info(tso) == mvar);
-    // actually perform the putMVar for the thread that we just woke up
-    PerformPut(tso,StgMVar_value(mvar));
-    
     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
     }
-    
-    // indicate that the putMVar has now completed:
+
+loop2:
+    if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+        tso = StgTSO__link(tso);
+        goto loop2;
+    }
+
+    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
+    ASSERT(StgTSO_block_info(tso) == mvar);
+
+    // actually perform the putMVar for the thread that we just woke up
+    PerformPut(tso,StgMVar_value(mvar));
+
+    // indicate that the MVar operation has now completed.
     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
     
     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
 
-    foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
+    foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
     
     unlockClosure(mvar, stg_MVAR_DIRTY_info);
     RET_P(val);
@@ -1283,22 +1298,29 @@ loop:
     // There are putMVar(s) waiting... wake up the first thread on the queue
     
     tso = StgMVarTSOQueue_tso(q);
-    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
-    ASSERT(StgTSO_block_info(tso) == mvar);
-    // actually perform the putMVar for the thread that we just woke up
-    PerformPut(tso,StgMVar_value(mvar));
-    
     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
     }
-    
-    // indicate that the putMVar has now completed:
+
+loop2:
+    if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+        tso = StgTSO__link(tso);
+        goto loop2;
+    }
+
+    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
+    ASSERT(StgTSO_block_info(tso) == mvar);
+
+    // actually perform the putMVar for the thread that we just woke up
+    PerformPut(tso,StgMVar_value(mvar));
+
+    // indicate that the MVar operation has now completed.
     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
     
     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
 
-    foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
+    foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
     
     unlockClosure(mvar, stg_MVAR_DIRTY_info);
     RET_P(val);
@@ -1326,7 +1348,7 @@ stg_putMVarzh
     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 
         // see Note [mvar-heap-check] above
-        HP_CHK_GEN_TICKY(SIZEOF_StgMVarTSOQueue, R1_PTR|R2_PTR, stg_putMVarzh);
+        HP_CHK_GEN_TICKY(SIZEOF_StgMVarTSOQueue, R1_PTR & R2_PTR, stg_putMVarzh);
 
         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
 
@@ -1368,24 +1390,31 @@ loop:
     // There are takeMVar(s) waiting: wake up the first one
     
     tso = StgMVarTSOQueue_tso(q);
+    StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
+    if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+    }
+
+loop2:
+    if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+        tso = StgTSO__link(tso);
+        goto loop2;
+    }
+
     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
     ASSERT(StgTSO_block_info(tso) == mvar);
+
     // actually perform the takeMVar
     PerformTake(tso, val);
 
+    // indicate that the MVar operation has now completed.
+    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
+    
     if (TO_W_(StgTSO_dirty(tso)) == 0) {
         foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
     }
     
-    StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
-    if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
-    }
-    
-    // indicate that the takeMVar has now completed:
-    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
-    
-    foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
+    foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
 
     unlockClosure(mvar, stg_MVAR_DIRTY_info);
     jump %ENTRY_CODE(Sp(0));
@@ -1431,29 +1460,34 @@ loop:
         goto loop;
     }
 
-    /* There are takeMVar(s) waiting: wake up the first one
-     */
     // There are takeMVar(s) waiting: wake up the first one
     
     tso = StgMVarTSOQueue_tso(q);
+    StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
+    if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+    }
+
+loop2:
+    if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+        tso = StgTSO__link(tso);
+        goto loop2;
+    }
+
     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
     ASSERT(StgTSO_block_info(tso) == mvar);
+
     // actually perform the takeMVar
     PerformTake(tso, val);
 
+    // indicate that the MVar operation has now completed.
+    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
+    
     if (TO_W_(StgTSO_dirty(tso)) == 0) {
         foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
     }
     
-    StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
-    if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
-    }
-    
-    // indicate that the takeMVar has now completed:
-    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
-    
-    foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
+    foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
 
     unlockClosure(mvar, stg_MVAR_DIRTY_info);
     jump %ENTRY_CODE(Sp(0));
@@ -1522,7 +1556,7 @@ stg_newBCOzh
     
     bitmap_arr = R5;
 
-    words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
+    words = BYTES_TO_WDS(SIZEOF_StgBCO) + BYTE_ARR_WDS(bitmap_arr);
     bytes = WDS(words);
 
     ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R5_PTR, stg_newBCOzh );
@@ -1540,7 +1574,7 @@ stg_newBCOzh
     W_ i;
     i = 0;
 for:
-    if (i < StgArrWords_words(bitmap_arr)) {
+    if (i < BYTE_ARR_WDS(bitmap_arr)) {
        StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
        i = i + 1;
        goto for;
@@ -1634,7 +1668,7 @@ for:
        is promoted. */
     
     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
-    StgArrWords_words(nptrs_arr) = nptrs;
+    StgArrWords_bytes(nptrs_arr) = WDS(nptrs);
     p = 0;
 for2:
     if(p < nptrs) {
@@ -1991,6 +2025,17 @@ stg_getSparkzh
 #endif
 }
 
+stg_numSparkszh
+{
+  W_ n;
+#ifdef THREADED_RTS
+  (n) = foreign "C" dequeElements(Capability_sparks(MyCapability()));
+#else
+  n = 0;
+#endif
+  RET_N(n);
+}
+
 stg_traceEventzh
 {
    W_ msg;
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)