Add optional eager black-holing, with new flag -feager-blackholing

Eager blackholing can improve parallel performance by reducing the
chances that two threads perform the same computation.  However, it
has a cost: one extra memory write per thunk entry.  

To get the best results, any code which may be executed in parallel
should be compiled with eager blackholing turned on.  But since
there's a cost for sequential code, we make it optional and turn it on
for the parallel package only.  It might be a good idea to compile
applications (or modules) with parallel code in with
-feager-blackholing.

ToDo: document -feager-blackholing.

14 files changed, 30 insertions, 52 deletions

diff --git a/rts/Capability.c b/rts/Capability.c
index 0b3c84430b..27a2d51eb4 100644
--- a/rts/Capability.c
+++ b/rts/Capability.c
@@ -205,6 +205,7 @@ initCapability( Capability *cap, nat i )
     cap->sparks_pruned      = 0;
 #endif
 
+    cap->f.stgEagerBlackholeInfo = (W_)&__stg_EAGER_BLACKHOLE_info;
     cap->f.stgGCEnter1     = (F_)__stg_gc_enter_1;
     cap->f.stgGCFun        = (F_)__stg_gc_fun;
 
diff --git a/rts/ClosureFlags.c b/rts/ClosureFlags.c
index eea609eff7..05baad72d4 100644
--- a/rts/ClosureFlags.c
+++ b/rts/ClosureFlags.c
@@ -69,8 +69,6 @@ StgWord16 closure_flags[] = {
 /* STOP_FRAME	   	= */ (     _BTM                                  ),
 /* CAF_BLACKHOLE   	= */ ( 	   _BTM|_NS|              _UPT           ),
 /* BLACKHOLE		= */ ( 	        _NS|              _UPT           ),
-/* SE_BLACKHOLE		= */ ( 	        _NS|              _UPT           ),
-/* SE_CAF_BLACKHOLE	= */ ( 	        _NS|              _UPT           ),
 /* MVAR_CLEAN	   	= */ (_HNF|     _NS|         _MUT|_UPT           ),
 /* MVAR_DIRTY	   	= */ (_HNF|     _NS|         _MUT|_UPT           ),
 /* ARR_WORDS		= */ (_HNF|     _NS|              _UPT           ),
@@ -87,7 +85,6 @@ StgWord16 closure_flags[] = {
 /* FETCH_ME		= */ (_HNF|     _NS|         _MUT|_UPT           ),
 /* FETCH_ME_BQ          = */ ( 	        _NS|         _MUT|_UPT           ),
 /* RBH                  = */ ( 	        _NS|         _MUT|_UPT           ),
-/* EVACUATED		= */ ( 0                                         ),
 /* REMOTE_REF		= */ (_HNF|     _NS|              _UPT           ),
 /* TVAR_WATCH_QUEUE     = */ (          _NS|         _MUT|_UPT           ),
 /* INVARIANT_CHECK_QUEUE= */ (          _NS|         _MUT|_UPT           ),
@@ -101,6 +98,6 @@ StgWord16 closure_flags[] = {
 /* WHITEHOLE		= */ ( 0                                         )
 };
 
-#if N_CLOSURE_TYPES != 73
+#if N_CLOSURE_TYPES != 70
 #error Closure types changed: update ClosureFlags.c!
 #endif
diff --git a/rts/FrontPanel.c b/rts/FrontPanel.c
index 5dfe87ac33..2ce91e2c65 100644
--- a/rts/FrontPanel.c
+++ b/rts/FrontPanel.c
@@ -664,8 +664,7 @@ residencyCensus( void )
 			break;
 
 		    case CAF_BLACKHOLE:
-		    case SE_CAF_BLACKHOLE:
-		    case SE_BLACKHOLE:
+		    case EAGER_BLACKHOLE:
 		    case BLACKHOLE:
 /*		    case BLACKHOLE_BQ: FIXME: case does not exist */
 			size = sizeW_fromITBL(info);
diff --git a/rts/LdvProfile.c b/rts/LdvProfile.c
index 0cd80dee65..6a807cf377 100644
--- a/rts/LdvProfile.c
+++ b/rts/LdvProfile.c
@@ -143,9 +143,7 @@ processHeapClosureForDead( StgClosure *c )
     case FUN_1_1:
     case FUN_0_2:
     case BLACKHOLE:
-    case SE_BLACKHOLE:
     case CAF_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
     case IND_PERM:
     case IND_OLDGEN_PERM:
 	/*
diff --git a/rts/Linker.c b/rts/Linker.c
index 1fbe6027d2..67a510b965 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -763,6 +763,7 @@ typedef struct _RtsSymbolVal {
       SymI_HasProto(stable_ptr_table)			\
       SymI_HasProto(stackOverflow)			\
       SymI_HasProto(stg_CAF_BLACKHOLE_info)		\
+      SymI_HasProto(__stg_EAGER_BLACKHOLE_info)		\
       SymI_HasProto(awakenBlockedQueue)			\
       SymI_HasProto(startTimer)                         \
       SymI_HasProto(stg_CHARLIKE_closure)		\
diff --git a/rts/Printer.c b/rts/Printer.c
index 3e80bd1a6f..1ad63063f8 100644
--- a/rts/Printer.c
+++ b/rts/Printer.c
@@ -306,14 +306,6 @@ printClosure( StgClosure *obj )
             debugBelch("BH\n"); 
             break;
 
-    case SE_BLACKHOLE:
-            debugBelch("SE_BH\n"); 
-            break;
-
-    case SE_CAF_BLACKHOLE:
-            debugBelch("SE_CAF_BH\n"); 
-            break;
-
     case ARR_WORDS:
         {
             StgWord i;
diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c
index 9cb47a19fd..36d4eb5f6f 100644
--- a/rts/ProfHeap.c
+++ b/rts/ProfHeap.c
@@ -144,8 +144,6 @@ static char *type_names[] = {
     "STOP_FRAME",
     "CAF_BLACKHOLE",
     "BLACKHOLE",
-    "SE_BLACKHOLE",
-    "SE_CAF_BLACKHOLE",
     "MVAR_CLEAN",
     "MVAR_DIRTY",
     "ARR_WORDS",
@@ -162,7 +160,6 @@ static char *type_names[] = {
     "FETCH_ME",
     "FETCH_ME_BQ",
     "RBH",
-    "EVACUATED",
     "REMOTE_REF",
     "TVAR_WATCH_QUEUE",
     "INVARIANT_CHECK_QUEUE",
@@ -173,6 +170,7 @@ static char *type_names[] = {
     "ATOMICALLY_FRAME",
     "CATCH_RETRY_FRAME",
     "CATCH_STM_FRAME",
+    "WHITEHOLE",
     "N_CLOSURE_TYPES"
   };
 #endif
@@ -960,8 +958,6 @@ heapCensusChain( Census *census, bdescr *bd )
 	    case IND_OLDGEN:
 	    case IND_OLDGEN_PERM:
 	    case CAF_BLACKHOLE:
-	    case SE_CAF_BLACKHOLE:
-	    case SE_BLACKHOLE:
 	    case BLACKHOLE:
 	    case FUN_1_0:
 	    case FUN_0_1:
diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c
index 8d6126af2d..2bd213ad3d 100644
--- a/rts/RetainerProfile.c
+++ b/rts/RetainerProfile.c
@@ -453,8 +453,6 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
     case CONSTR_0_2:
     case CAF_BLACKHOLE:
     case BLACKHOLE:
-    case SE_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
     case ARR_WORDS:
 	*first_child = NULL;
 	return;
@@ -958,8 +956,6 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
 	case CONSTR_0_2:
 	case CAF_BLACKHOLE:
 	case BLACKHOLE:
-	case SE_BLACKHOLE:
-	case SE_CAF_BLACKHOLE:
 	case ARR_WORDS:
 	    // one child (fixed), no SRT
 	case MUT_VAR_CLEAN:
@@ -1112,8 +1108,6 @@ isRetainer( StgClosure *c )
 	// blackholes
     case CAF_BLACKHOLE:
     case BLACKHOLE:
-    case SE_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
 	// indirection
     case IND_PERM:
     case IND_OLDGEN_PERM:
diff --git a/rts/Sanity.c b/rts/Sanity.c
index 8f3b627a2b..71eae4490c 100644
--- a/rts/Sanity.c
+++ b/rts/Sanity.c
@@ -312,10 +312,6 @@ checkClosure( StgClosure* p )
     case IND_PERM:
     case IND_OLDGEN:
     case IND_OLDGEN_PERM:
-#ifdef TICKY_TICKY
-    case SE_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
-#endif
     case BLACKHOLE:
     case CAF_BLACKHOLE:
     case STABLE_NAME:
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index d22a880917..7f7cf78f7b 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -384,14 +384,33 @@ INFO_TABLE(stg_CAF_BLACKHOLE,0,1,CAF_BLACKHOLE,"CAF_BLACKHOLE","CAF_BLACKHOLE")
     jump stg_block_blackhole;
 }
 
-#ifdef EAGER_BLACKHOLING
-INFO_TABLE(stg_SE_BLACKHOLE,0,1,SE_BLACKHOLE,"SE_BLACKHOLE","SE_BLACKHOLE")
-{ foreign "C" barf("SE_BLACKHOLE object entered!") never returns; }
+INFO_TABLE(__stg_EAGER_BLACKHOLE,0,1,BLACKHOLE,"EAGER_BLACKHOLE","EAGER_BLACKHOLE")
+{
+    TICK_ENT_BH();
+
+#ifdef THREADED_RTS
+    // foreign "C" debugBelch("BLACKHOLE entry\n");
+#endif
 
-INFO_TABLE(stg_SE_CAF_BLACKHOLE,0,1,SE_CAF_BLACKHOLE,"SE_CAF_BLACKHOLE","SE_CAF_BLACKHOLE")
-{ foreign "C" barf("SE_CAF_BLACKHOLE object entered!") never returns; }
+    /* Actually this is not necessary because R1 is about to be destroyed. */
+    LDV_ENTER(R1);
+
+#if defined(THREADED_RTS)
+    ACQUIRE_LOCK(sched_mutex "ptr");
+    // released in stg_block_blackhole_finally
 #endif
 
+    /* Put ourselves on the blackhole queue */
+    StgTSO__link(CurrentTSO) = W_[blackhole_queue];
+    W_[blackhole_queue] = CurrentTSO;
+
+    /* jot down why and on what closure we are blocked */
+    StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16;
+    StgTSO_block_info(CurrentTSO) = R1;
+
+    jump stg_block_blackhole;
+}
+
 /* ----------------------------------------------------------------------------
    Whiteholes are used for the "locked" state of a closure (see lockClosure())
    ------------------------------------------------------------------------- */
diff --git a/rts/ThreadPaused.c b/rts/ThreadPaused.c
index 5463deecb8..674d0d9ca3 100644
--- a/rts/ThreadPaused.c
+++ b/rts/ThreadPaused.c
@@ -250,9 +250,6 @@ threadPaused(Capability *cap, StgTSO *tso)
 	    }
 
 	    if (bh->header.info != &stg_CAF_BLACKHOLE_info) {
-#if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
-		debugBelch("Unexpected lazy BHing required at 0x%04lx\n",(long)bh);
-#endif
 		// zero out the slop so that the sanity checker can tell
 		// where the next closure is.
 		DEBUG_FILL_SLOP(bh);
@@ -261,7 +258,7 @@ threadPaused(Capability *cap, StgTSO *tso)
 		// We pretend that bh is now dead.
 		LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)bh);
 #endif
-
+                // an EAGER_BLACKHOLE gets turned into a BLACKHOLE here.
 #ifdef THREADED_RTS
                 cur_bh_info = (const StgInfoTable *)
                     cas((StgVolatilePtr)&bh->header.info, 
diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index b43c0ea532..fcd7cb16ed 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -621,8 +621,6 @@ thread_obj (StgInfoTable *info, StgPtr p)
     case MUT_VAR_CLEAN:
     case MUT_VAR_DIRTY:
     case CAF_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
-    case SE_BLACKHOLE:
     case BLACKHOLE:
     {
 	StgPtr end;
diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index 736c6c8d88..bbb7fe5795 100644
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -626,8 +626,6 @@ loop:
       return;
 
   case CAF_BLACKHOLE:
-  case SE_CAF_BLACKHOLE:
-  case SE_BLACKHOLE:
   case BLACKHOLE:
       copyPart(p,q,BLACKHOLE_sizeW(),sizeofW(StgHeader),stp);
       return;
@@ -1038,8 +1036,6 @@ selector_loop:
       case THUNK_0_2:
       case THUNK_STATIC:
       case CAF_BLACKHOLE:
-      case SE_CAF_BLACKHOLE:
-      case SE_BLACKHOLE:
       case BLACKHOLE:
 	  // not evaluated yet 
 	  goto bale_out;
diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c
index b8fb54bfcd..24f19c93e1 100644
--- a/rts/sm/Scav.c
+++ b/rts/sm/Scav.c
@@ -504,8 +504,6 @@ scavenge_block (bdescr *bd)
 	break;
 
     case CAF_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
-    case SE_BLACKHOLE:
     case BLACKHOLE:
 	p += BLACKHOLE_sizeW();
 	break;
@@ -881,8 +879,6 @@ linear_scan:
 	}
 
 	case CAF_BLACKHOLE:
-	case SE_CAF_BLACKHOLE:
-	case SE_BLACKHOLE:
 	case BLACKHOLE:
 	case ARR_WORDS:
 	    break;
@@ -1197,8 +1193,6 @@ scavenge_one(StgPtr p)
     }
 
     case CAF_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
-    case SE_BLACKHOLE:
     case BLACKHOLE:
 	break;