Fix bug in eval_thunk_selector()

[ghc-hetmet.git] / rts / sm / Evac.c

diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index 2bbd5c9..3593943 100644 (file)
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -37,7 +37,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
@@ -57,17 +56,18 @@ alloc_for_copy (nat size, step *stp)
     /* 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;
+    
+    ASSERT(ws->todo_free >= ws->todo_bd->free && ws->todo_free <= ws->todo_lim);
+    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
    -------------------------------------------------------------------------- */
@@ -164,7 +164,11 @@ 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
         prev = (StgSelector*)((StgClosure *)p)->payload[0];
 
         // Update the THUNK_SELECTOR with an indirection to the
@@ -239,7 +243,7 @@ selector_chain:
     // In threaded mode, we'll use WHITEHOLE to lock the selector
     // thunk while we evaluate it.
     {
-       info_ptr = (StgInfoTable *)xchg((StgPtr)&p->header.info, (W_)&stg_WHITEHOLE_info);
+       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);
@@ -295,7 +299,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 +404,11 @@ 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);
+    *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;
 }