X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FSparks.c;h=1a839ab315a2aee1d53b7c44322417e9a0de282c;hb=27de38efce6d73d2a0209f803cfa98c82773e773;hp=615d832e33e8de18e45e095030da158dc419d843;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/rts/Sparks.c b/rts/Sparks.c
index 615d832..1a839ab 100644
--- a/rts/Sparks.c
+++ b/rts/Sparks.c
@@ -8,9 +8,9 @@
 
 #include "PosixSource.h"
 #include "Rts.h"
+#include "Storage.h"
 #include "Schedule.h"
 #include "SchedAPI.h"
-#include "Storage.h"
 #include "RtsFlags.h"
 #include "RtsUtils.h"
 #include "ParTicky.h"
@@ -21,6 +21,7 @@
 # include "GranSimRts.h"
 # endif
 #include "Sparks.h"
+#include "Trace.h"
 
 #if defined(THREADED_RTS) || defined(PARALLEL_HASKELL)
 
@@ -62,6 +63,11 @@ initSparkPools( void )
 #endif
 }
 
+void
+freeSparkPool(StgSparkPool *pool) {
+    stgFree(pool->base);
+}
+
 /* -----------------------------------------------------------------------------
  * 
  * findSpark: find a spark on the current Capability that we can fork
@@ -96,76 +102,6 @@ findSpark (Capability *cap)
 }
 
 /* -----------------------------------------------------------------------------
- * Mark all nodes pointed to by sparks in the spark queues (for GC) Does an
- * implicit slide i.e. after marking all sparks are at the beginning of the
- * spark pool and the spark pool only contains sparkable closures 
- * -------------------------------------------------------------------------- */
-
-void
-markSparkQueue (evac_fn evac)
-{ 
-    StgClosure **sparkp, **to_sparkp;
-    nat i, n, pruned_sparks; // stats only
-    StgSparkPool *pool;
-    Capability *cap;
-    
-    PAR_TICKY_MARK_SPARK_QUEUE_START();
-    
-    n = 0;
-    pruned_sparks = 0;
-    for (i = 0; i < n_capabilities; i++) {
-	cap = &capabilities[i];
-	pool = &(cap->r.rSparks);
-	
-	ASSERT_SPARK_POOL_INVARIANTS(pool);
-
-#if defined(PARALLEL_HASKELL)
-	// stats only
-	n = 0;
-	pruned_sparks = 0;
-#endif
-	
-	sparkp = pool->hd;
-	to_sparkp = pool->hd;
-	while (sparkp != pool->tl) {
-	    ASSERT(to_sparkp<=sparkp);
-	    ASSERT(*sparkp!=NULL);
-	    ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgClosure *)*sparkp)));
-	    // ToDo?: statistics gathering here (also for GUM!)
-	    if (closure_SHOULD_SPARK(*sparkp)) {
-		evac(sparkp);
-		*to_sparkp++ = *sparkp;
-		n++;
-	    } else {
-		pruned_sparks++;
-	    }
-	    sparkp++;
-	    if (sparkp == pool->lim) {
-		sparkp = pool->base;
-	    }
-	}
-	pool->tl = to_sparkp;
-	
-	PAR_TICKY_MARK_SPARK_QUEUE_END(n);
-	
-#if defined(PARALLEL_HASKELL)
-	IF_DEBUG(scheduler,
-		 debugBelch("markSparkQueue: marked %d sparks and pruned %d sparks on [%x]",
-			    n, pruned_sparks, mytid));
-#else
-	IF_DEBUG(scheduler,
-	       debugBelch("markSparkQueue: marked %d sparks and pruned %d sparks\n",
-			  n, pruned_sparks));
-#endif
-	
-	IF_DEBUG(scheduler,
-		 debugBelch("markSparkQueue:   new spark queue len=%d; (hd=%p; tl=%p)\n",
-			    sparkPoolSize(pool), pool->hd, pool->tl));
-	
-    }
-}
-
-/* -----------------------------------------------------------------------------
  * 
  * Turn a spark into a real thread
  *
@@ -193,6 +129,12 @@ newSpark (StgRegTable *reg, StgClosure *p)
 {
     StgSparkPool *pool = &(reg->rSparks);
 
+    /* I am not sure whether this is the right thing to do.
+     * Maybe it is better to exploit the tag information
+     * instead of throwing it away?
+     */
+    p = UNTAG_CLOSURE(p);
+
     ASSERT_SPARK_POOL_INVARIANTS(pool);
 
     if (closure_SHOULD_SPARK(p)) {
@@ -220,6 +162,80 @@ newSpark (StgRegTable *reg, StgClosure *p)
     return 1;
 }
 
+/* -----------------------------------------------------------------------------
+ * Mark all nodes pointed to by sparks in the spark queues (for GC) Does an
+ * implicit slide i.e. after marking all sparks are at the beginning of the
+ * spark pool and the spark pool only contains sparkable closures 
+ * -------------------------------------------------------------------------- */
+
+void
+markSparkQueue (evac_fn evac, void *user, Capability *cap)
+{ 
+    StgClosure *spark, **sparkp, **to_sparkp;
+    nat n, pruned_sparks; // stats only
+    StgSparkPool *pool;
+    
+    PAR_TICKY_MARK_SPARK_QUEUE_START();
+    
+    n = 0;
+    pruned_sparks = 0;
+    
+    pool = &(cap->r.rSparks);
+    
+    ASSERT_SPARK_POOL_INVARIANTS(pool);
+    
+    sparkp = pool->hd;
+    to_sparkp = pool->hd;
+    while (sparkp != pool->tl) {
+        ASSERT(*sparkp!=NULL);
+        ASSERT(LOOKS_LIKE_CLOSURE_PTR(((StgClosure *)*sparkp)));
+        // ToDo?: statistics gathering here (also for GUM!)
+        evac(user,sparkp);
+        spark = *sparkp;
+        if (!closure_SHOULD_SPARK(spark)) {
+            pruned_sparks++;
+        } else{
+            *to_sparkp++ = spark;
+            if (to_sparkp == pool->lim) {
+                to_sparkp = pool->base;
+            }
+            n++;
+        }
+        sparkp++;
+        if (sparkp == pool->lim) {
+            sparkp = pool->base;
+        }
+    }
+    pool->tl = to_sparkp;
+	
+    PAR_TICKY_MARK_SPARK_QUEUE_END(n);
+	
+    debugTrace(DEBUG_sched, 
+               "marked %d sparks, pruned %d sparks",
+               n, pruned_sparks);
+    
+    debugTrace(DEBUG_sched,
+               "new spark queue len=%d; (hd=%p; tl=%p)",
+               sparkPoolSize(pool), pool->hd, pool->tl);
+}
+
+void
+traverseSparkQueue (evac_fn evac, void *user, Capability *cap)
+{
+    StgClosure **sparkp;
+    StgSparkPool *pool;
+    
+    pool = &(cap->r.rSparks);
+    sparkp = pool->hd;
+    while (sparkp != pool->tl) {
+        evac(sparkp, user);
+        sparkp++;
+        if (sparkp == pool->lim) {
+            sparkp = pool->base;
+        }
+    }
+}
+
 #else
 
 StgInt
@@ -229,6 +245,7 @@ newSpark (StgRegTable *reg STG_UNUSED, StgClosure *p STG_UNUSED)
     return 1;
 }
 
+
 #endif /* PARALLEL_HASKELL || THREADED_RTS */
 
 
@@ -825,8 +842,9 @@ markSparkQueue(void)
       // ToDo?: statistics gathering here (also for GUM!)
       sp->node = (StgClosure *)MarkRoot(sp->node);
     }
+
   IF_DEBUG(gc,
-	   debugBelch("@@ markSparkQueue: spark statistics at start of GC:");
+	   debugBelch("markSparkQueue: spark statistics at start of GC:");
 	   print_sparkq_stats());
 }