[commit: ghc] master: Fix for earger blackholing of thunks with no free variables (#6146) (21a53a1)

[Simon Marlow]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/21a53a1cd5a9784aca7b78cc972f917e71938124

>---------------------------------------------------------------

commit 21a53a1cd5a9784aca7b78cc972f917e71938124
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Thu Jun 7 15:45:32 2012 +0100

    Fix for earger blackholing of thunks with no free variables (#6146)
    
    A thunk with no free variables was not getting blackholed when
    -feager-blackholing was on, but we were nevertheless pushing the
    stg_bh_upd_frame version of the update frame that expects to see a
    black hole.
    
    I fixed this twice for good measure:
    
     - we now call blackHoleOnEntry when pushing the update frame to check
       whether the closure was actually blackholed, and so that we use the
       same predicate in both places
    
     - we now black hole thunks even if they have no free variables.
       These only occur when optimisation is off, but presumably if you say
       -feager-blackholing then that's what you want to happen.

>---------------------------------------------------------------

 compiler/codeGen/CgClosure.lhs    |    7 ++++---
 compiler/codeGen/ClosureInfo.lhs  |    2 +-
 compiler/codeGen/StgCmmBind.hs    |   17 ++++++++++-------
 compiler/codeGen/StgCmmClosure.hs |    2 +-
 4 files changed, 16 insertions(+), 12 deletions(-)

diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 4d1ce50..ea295ec 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -506,9 +506,10 @@ setupUpdate closure_info code
       else do
           tickyPushUpdateFrame
           dflags <- getDynFlags
-          if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
-              then pushBHUpdateFrame (CmmReg nodeReg) code
-              else pushUpdateFrame   (CmmReg nodeReg) code
+          if blackHoleOnEntry closure_info &&
+             not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
+               then pushBHUpdateFrame (CmmReg nodeReg) code
+               else pushUpdateFrame   (CmmReg nodeReg) code
   
   | otherwise	-- A static closure
   = do 	{ tickyUpdateBhCaf closure_info
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index b3a365b..ac60677 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -731,7 +731,7 @@ blackHoleOnEntry cl_info
   = case closureLFInfo cl_info of
 	LFReEntrant _ _ _ _	  -> False
         LFLetNoEscape _           -> False
-        LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks.
+        LFThunk _ _no_fvs _updatable _ _ -> True
         _other -> panic "blackHoleOnEntry"      -- Should never happen
 
 isKnownFun :: LambdaFormInfo -> Bool
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 9bf57b1..3ae25b4 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -565,12 +565,15 @@ setupUpdate closure_info node body
       then do tickyUpdateFrameOmitted; body
       else do
           tickyPushUpdateFrame
-          --dflags <- getDynFlags
-          let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel]
-          --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
-          --  then pushUpdateFrame es body -- XXX black hole
-          --  else pushUpdateFrame es body
-          pushUpdateFrame es body
+          dflags <- getDynFlags
+          let
+              bh = blackHoleOnEntry closure_info &&
+                   not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
+
+              lbl | bh        = mkBHUpdInfoLabel
+                  | otherwise = mkUpdInfoLabel
+
+          pushUpdateFrame [CmmReg (CmmLocal node), mkLblExpr lbl] body
 
   | otherwise	-- A static closure
   = do 	{ tickyUpdateBhCaf closure_info
@@ -579,7 +582,7 @@ setupUpdate closure_info node body
 	  then do	-- Blackhole the (updatable) CAF:
                 { upd_closure <- link_caf True
 		; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
-                                     mkLblExpr mkUpdInfoLabel] body } -- XXX black hole
+                                   mkLblExpr mkBHUpdInfoLabel] body }
 	  else do {tickyUpdateFrameOmitted; body}
     }
 
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 9185002..de7ab3d 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -728,7 +728,7 @@ blackHoleOnEntry cl_info
   = case closureLFInfo cl_info of
 	LFReEntrant _ _ _ _	  -> False
 	LFLetNoEscape 		  -> False
-        LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks.
+        LFThunk _ _no_fvs _updatable _ _ -> True
         _other -> panic "blackHoleOnEntry"      -- Should never happen
 
 isStaticClosure :: ClosureInfo -> Bool