X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2Fsm%2FEvac.c;h=4c386f75df27a01646b919b274bbd10045f31989;hb=2aa877f8588da099351ef51efca3605fd87ea768;hp=26646fe4a790c1f99fc71a378544abc2fbd30973;hpb=a78f4a5c3f20f0a86050280c83923c2c2ad36b21;p=ghc-hetmet.git

diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index 26646fe..4c386f7 100644
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -21,6 +21,10 @@
 #include "Prelude.h"
 #include "LdvProfile.h"
 
+#if defined(PROF_SPIN) && defined(THREADED_RTS)
+StgWord64 whitehole_spin = 0;
+#endif
+
 /* Used to avoid long recursion due to selector thunks
  */
 #define MAX_THUNK_SELECTOR_DEPTH 16
@@ -37,7 +41,6 @@ alloc_for_copy (nat size, step *stp)
 {
     StgPtr to;
     step_workspace *ws;
-    bdescr *bd;
 
     /* Find out where we're going, using the handy "to" pointer in 
      * the step of the source object.  If it turns out we need to
@@ -52,22 +55,22 @@ alloc_for_copy (nat size, step *stp)
 	}
     }
     
-    ws = &gct->steps[stp->gen_no][stp->no];
+    ws = &gct->steps[stp->abs_no];
+    // this compiles to a single mem access to stp->abs_no only
     
     /* chain a new block onto the to-space for the destination step if
      * necessary.
      */
-    bd = ws->todo_bd;
-    to = bd->free;
-    if (to + size >= bd->start + BLOCK_SIZE_W) {
-	bd = gc_alloc_todo_block(ws);
-	to = bd->free;
+    to = ws->todo_free;
+    if (to + size > ws->todo_lim) {
+	to = gc_alloc_todo_block(ws);
     }
-    bd->free = to + size;
+    ws->todo_free = to + size;
+    ASSERT(ws->todo_free >= ws->todo_bd->free && ws->todo_free <= ws->todo_lim);
 
     return to;
 }
-  
+
 /* -----------------------------------------------------------------------------
    The evacuate() code
    -------------------------------------------------------------------------- */
@@ -93,8 +96,11 @@ STATIC_INLINE void
 evacuate_large(StgPtr p)
 {
   bdescr *bd = Bdescr(p);
-  step *stp;
+  step *stp, *new_stp;
   step_workspace *ws;
+    
+  stp = bd->step;
+  ACQUIRE_SPIN_LOCK(&stp->sync_large_objects);
 
   // object must be at the beginning of the block (or be a ByteArray)
   ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS ||
@@ -105,16 +111,14 @@ evacuate_large(StgPtr p)
     /* Don't forget to set the gct->failed_to_evac flag if we didn't get
      * the desired destination (see comments in evacuate()).
      */
-    if (bd->step < gct->evac_step) {
-      gct->failed_to_evac = rtsTrue;
-      TICK_GC_FAILED_PROMOTION();
+    if (stp < gct->evac_step) {
+	gct->failed_to_evac = rtsTrue;
+	TICK_GC_FAILED_PROMOTION();
     }
+    RELEASE_SPIN_LOCK(&stp->sync_large_objects);
     return;
   }
 
-  stp = bd->step;
-
-  ACQUIRE_SPIN_LOCK(&stp->sync_large_objects);
   // remove from large_object list 
   if (bd->u.back) {
     bd->u.back->link = bd->link;
@@ -124,25 +128,26 @@ evacuate_large(StgPtr p)
   if (bd->link) {
     bd->link->u.back = bd->u.back;
   }
-  RELEASE_SPIN_LOCK(&stp->sync_large_objects);
   
   /* link it on to the evacuated large object list of the destination step
    */
-  stp = bd->step->to;
-  if (stp < gct->evac_step) {
+  new_stp = stp->to;
+  if (new_stp < gct->evac_step) {
       if (gct->eager_promotion) {
-	  stp = gct->evac_step;
+	  new_stp = gct->evac_step;
       } else {
 	  gct->failed_to_evac = rtsTrue;
       }
   }
 
-  ws = &gct->steps[stp->gen_no][stp->no];
-  bd->step = stp;
-  bd->gen_no = stp->gen_no;
+  ws = &gct->steps[new_stp->abs_no];
+  bd->flags |= BF_EVACUATED;
+  bd->step = new_stp;
+  bd->gen_no = new_stp->gen_no;
   bd->link = ws->todo_large_objects;
   ws->todo_large_objects = bd;
-  bd->flags |= BF_EVACUATED;
+
+  RELEASE_SPIN_LOCK(&stp->sync_large_objects);
 }
 
 /* -----------------------------------------------------------------------------
@@ -164,7 +169,17 @@ unchain_thunk_selectors(StgSelector *p, StgClosure *val)
     prev = NULL;
     while (p)
     {
+#ifdef THREADED_RTS
+        ASSERT(p->header.info == &stg_WHITEHOLE_info);
+#else
         ASSERT(p->header.info == &stg_BLACKHOLE_info);
+#endif
+        // val must be in to-space.  Not always: when we recursively
+        // invoke eval_thunk_selector(), the recursive calls will not 
+        // evacuate the value (because we want to select on the value,
+        // not evacuate it), so in this case val is in from-space.
+        // ASSERT(!HEAP_ALLOCED(val) || Bdescr((P_)val)->gen_no > N || (Bdescr((P_)val)->flags & BF_EVACUATED));
+
         prev = (StgSelector*)((StgClosure *)p)->payload[0];
 
         // Update the THUNK_SELECTOR with an indirection to the
@@ -173,8 +188,9 @@ unchain_thunk_selectors(StgSelector *p, StgClosure *val)
         // EVACUATED closure always points to an object in the
         // same or an older generation (required by the short-cut
         // test in the EVACUATED case, below).
-        SET_INFO(p, &stg_IND_info);
         ((StgInd *)p)->indirectee = val;
+        write_barrier();
+        SET_INFO(p, &stg_IND_info);
 
         // For the purposes of LDV profiling, we have created an
         // indirection.
@@ -239,16 +255,26 @@ selector_chain:
     // In threaded mode, we'll use WHITEHOLE to lock the selector
     // thunk while we evaluate it.
     {
-	info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info);
-	if (info_ptr == (W_)&stg_WHITEHOLE_info) {
-            do {
-                info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info);
-            } while (info_ptr == (W_)&stg_WHITEHOLE_info);
-            goto bale_out;
-	}
-        // make sure someone else didn't get here first
+        do {
+            info_ptr = xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info);
+        } while (info_ptr == (W_)&stg_WHITEHOLE_info);
+
+        // make sure someone else didn't get here first...
         if (INFO_PTR_TO_STRUCT(info_ptr)->type != THUNK_SELECTOR) {
-            goto bale_out;
+            // v. tricky now.  The THUNK_SELECTOR has been evacuated
+            // by another thread, and is now either EVACUATED or IND.
+            // We need to extract ourselves from the current situation
+            // as cleanly as possible.
+            //   - unlock the closure
+            //   - update *q, we may have done *some* evaluation
+            //   - if evac, we need to call evacuate(), because we
+            //     need the write-barrier stuff.
+            //   - undo the chain we've built to point to p.
+            SET_INFO(p, (const StgInfoTable *)info_ptr);
+            *q = (StgClosure *)p;
+            if (evac) evacuate(q);
+            unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p);
+            return;
         }
     }
 #else
@@ -295,7 +321,7 @@ selector_loop:
 #ifdef PROFILING
               // For the purposes of LDV profiling, we have destroyed
               // the original selector thunk, p.
-              SET_INFO(p, info_ptr);
+              SET_INFO(p, (StgInfoTable *)info_ptr);
               LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC((StgClosure *)p);
               SET_INFO(p, &stg_BLACKHOLE_info);
 #endif
@@ -400,13 +426,14 @@ bale_out:
     // We didn't manage to evaluate this thunk; restore the old info
     // pointer.  But don't forget: we still need to evacuate the thunk itself.
     SET_INFO(p, (const StgInfoTable *)info_ptr);
+    // THREADED_RTS: we just unlocked the thunk, so another thread
+    // might get in and update it.  copy() will lock it again and
+    // check whether it was updated in the meantime.
+    *q = (StgClosure *)p;
     if (evac) {
-        copy(&val,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->step->to);
-    } else {
-        val = (StgClosure *)p;
+        copy(q,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->step->to);
     }
-    *q = val;
-    unchain_thunk_selectors(prev_thunk_selector, val);
+    unchain_thunk_selectors(prev_thunk_selector, *q);
     return;
 }