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.

9 files changed, 27 insertions, 28 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 0c3c007869..1c338243ab 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -63,7 +63,6 @@ module CLabel (
 
 	mkTopTickyCtrLabel,
         mkCAFBlackHoleInfoTableLabel,
-        mkSECAFBlackHoleInfoTableLabel,
 	mkRtsPrimOpLabel,
 	mkRtsSlowTickyCtrLabel,
 
@@ -348,10 +347,6 @@ mkEMPTY_MVAR_infoLabel		= RtsLabel (RtsInfo (sLit "stg_EMPTY_MVAR"))
 
 mkTopTickyCtrLabel		= RtsLabel (RtsData (sLit "top_ct"))
 mkCAFBlackHoleInfoTableLabel	= RtsLabel (RtsInfo (sLit "stg_CAF_BLACKHOLE"))
-mkSECAFBlackHoleInfoTableLabel	= if opt_DoTickyProfiling then
-                                    RtsLabel (RtsInfo (sLit "stg_SE_CAF_BLACKHOLE"))
-                                  else  -- RTS won't have info table unless -ticky is on
-                                    panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
 mkRtsPrimOpLabel primop		= RtsLabel (RtsPrimOp primop)
 
 moduleRegdLabel			= ModuleRegdLabel
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 06149b490d..69a4952ed6 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -267,6 +267,7 @@ data GlobalReg
 		-- We keep the address of some commonly-called 
 		-- functions in the register table, to keep code
 		-- size down:
+  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info
   | GCEnter1		-- stg_gc_enter_1
   | GCFun		-- stg_gc_fun
 
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 37359ed84b..2a01217803 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -748,6 +748,7 @@ pprGlobalReg gr = case gr of
     CurrentNursery -> ptext (sLit "CurrentNursery")
     HpAlloc        -> ptext (sLit "HpAlloc")
     BaseReg        -> ptext (sLit "BaseReg")
+    EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
     GCEnter1       -> ptext (sLit "stg_gc_enter_1")
     GCFun          -> ptext (sLit "stg_gc_fun")
 
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index dbfd20e424..e801aeee26 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -565,6 +565,7 @@ pprGlobalReg gr
         CurrentTSO     -> ptext (sLit "CurrentTSO")
         CurrentNursery -> ptext (sLit "CurrentNursery")
         HpAlloc        -> ptext (sLit "HpAlloc")
+        EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
         GCEnter1       -> ptext (sLit "stg_gc_enter_1")
         GCFun          -> ptext (sLit "stg_gc_fun")
         BaseReg        -> ptext (sLit "BaseReg")
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 902b975a91..80949e7513 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -50,6 +50,8 @@ import Module
 import ListSetOps
 import Util
 import BasicTypes
+import StaticFlags
+import DynFlags
 import Constants
 import Outputable
 import FastString
@@ -452,15 +454,9 @@ blackHoleIt :: ClosureInfo -> Code
 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
 
 emitBlackHoleCode :: Bool -> Code
-emitBlackHoleCode is_single_entry 
-  | eager_blackholing = do 
-	tickyBlackHole (not is_single_entry)
-	stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
-  | otherwise = 
-	nopC
-  where
-    bh_lbl | is_single_entry = mkRtsDataLabel (sLit "stg_SE_BLACKHOLE_info")
-	   | otherwise	     = mkRtsDataLabel (sLit "stg_BLACKHOLE_info")
+emitBlackHoleCode is_single_entry = do
+
+  dflags <- getDynFlags
 
 	-- If we wanted to do eager blackholing with slop filling,
 	-- we'd need to do it at the *end* of a basic block, otherwise
@@ -476,7 +472,16 @@ emitBlackHoleCode is_single_entry
         -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING 
         -- is unconditionally disabled. -- krc 1/2007
 
-    eager_blackholing = False 
+  let eager_blackholing =  not opt_SccProfilingOn
+                        && dopt Opt_EagerBlackHoling dflags
+
+  if eager_blackholing
+     then do
+          tickyBlackHole (not is_single_entry)
+          let bh_info = CmmReg (CmmGlobal EagerBlackholeInfo)
+	  stmtC (CmmStore (CmmReg nodeReg) bh_info)
+     else
+          nopC
 \end{code}
 
 \begin{code}
@@ -571,8 +576,7 @@ link_caf cl_info is_upd = do
   ; returnFC hp_rel }
   where
     bh_cl_info :: ClosureInfo
-    bh_cl_info | is_upd    = cafBlackHoleClosureInfo   cl_info
-	       | otherwise = seCafBlackHoleClosureInfo cl_info
+    bh_cl_info = cafBlackHoleClosureInfo cl_info
 
     ind_static_info :: CmmExpr
     ind_static_info = mkLblExpr mkIndStaticInfoLabel
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 213b9ea4a0..4de3537788 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -542,6 +542,7 @@ baseRegOffset HpLim		  = oFFSET_StgRegTable_rHpLim
 baseRegOffset CurrentTSO	  = oFFSET_StgRegTable_rCurrentTSO
 baseRegOffset CurrentNursery	  = oFFSET_StgRegTable_rCurrentNursery
 baseRegOffset HpAlloc		  = oFFSET_StgRegTable_rHpAlloc
+baseRegOffset EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo
 baseRegOffset GCEnter1		  = oFFSET_stgGCEnter1
 baseRegOffset GCFun		  = oFFSET_stgGCFun
 baseRegOffset BaseReg		  = panic "baseRegOffset:BaseReg"
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 07a833f5af..dcb41b4cc4 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -58,7 +58,7 @@ module ClosureInfo (
 	closureValDescr, closureTypeDescr,	-- profiling
 
 	isStaticClosure,
-	cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
+	cafBlackHoleClosureInfo,
 
 	staticClosureNeedsLink,
     ) where
@@ -959,16 +959,6 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
 		  closureType   = ty,
 		  closureDescr  = "" }
 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
-
-seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
-				         closureType = ty })
-  = ClosureInfo { closureName   = nm,
-		  closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
-		  closureSMRep  = BlackHoleRep,
-		  closureSRT    = NoC_SRT,
-		  closureType   = ty,
-		  closureDescr  = ""  }
-seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
 \end{code}
 
 %************************************************************************
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 9c25251b8e..ded2443845 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -275,6 +275,7 @@ data DynFlag
    | Opt_DryRun
    | Opt_DoAsmMangling
    | Opt_ExcessPrecision
+   | Opt_EagerBlackHoling
    | Opt_ReadUserPackageConf
    | Opt_NoHsMain
    | Opt_SplitObjs
@@ -1587,6 +1588,7 @@ fFlags = [
   ( "dicts-cheap",                      Opt_DictsCheap, const Supported ),
   ( "inline-if-enough-args",            Opt_InlineIfEnoughArgs, const Supported ),
   ( "excess-precision",                 Opt_ExcessPrecision, const Supported ),
+  ( "eager-blackholing",                Opt_EagerBlackHoling, const Supported ),
   ( "asm-mangling",                     Opt_DoAsmMangling, const Supported ),
   ( "print-bind-result",                Opt_PrintBindResult, const Supported ),
   ( "force-recomp",                     Opt_ForceRecomp, const Supported ),
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 4d03a284cf..ee39dcd999 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -768,6 +768,10 @@ cmmExprConFold referenceKind expr
            -- On powerpc (non-PIC), it's easier to jump directly to a label than
            -- to use the register table, so we replace these registers
            -- with the corresponding labels:
+        CmmReg (CmmGlobal EagerBlackholeInfo)
+          | not opt_PIC
+          -> cmmExprConFold referenceKind $
+             CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_EAGER_BLACKHOLE_INFO"))) 
         CmmReg (CmmGlobal GCEnter1)
           | not opt_PIC
           -> cmmExprConFold referenceKind $