[project @ 2001-09-10 07:24:09 by simonpj]

-----------------------------------
	Fix a strictness bug in the simplifier
	-----------------------------------

This one has been there a long time, but hasn't bitten till
now.  We should never float a let that is marked "sure to be
evaluated" out of a let.  It shouldn't happen, and there was
a warning to check, but the warning cried 'wolf' too often, so
we have generally ignored it. But the wolf called for supper,
when compiling spectral/expert with profiling on.

The fix is simple too:
	* use exprIsValue not exprIsCheap as the test
	* move the warning, so it doesn't cry wolf

Documentation with Simplify.simplRhs.

On the way, I'm going to conmmit a change in the same module,
which keeps unfolding info on lambda-bound variables.  This
improves the elimination of cases when the wrapper does the
'seq' -- then the worker gets to know that the arg is evaluated.

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 371a0c7..3a75225 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module SimplUtils (
-       simplBinder, simplBinders, simplRecIds, simplLetId,
+       simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinder,
        tryRhsTyLam, tryEtaExpansion,
        mkCase,
 
@@ -28,12 +28,11 @@ import CoreUtils    ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap,
                          findDefault
                        )
 import Subst           ( InScopeSet, mkSubst, substExpr )
-import qualified Subst ( simplBndrs, simplBndr, simplLetId )
+import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
 import Id              ( idType, idName, 
                          idUnfolding, idNewStrictness,
                          mkLocalId, idInfo
                        )
-import IdInfo          ( StrictnessInfo(..) )
 import Maybes          ( maybeToBool, catMaybes )
 import Name            ( setNameUnique )
 import NewDemand       ( isStrictDmd, isBotRes, splitStrictSig )
@@ -429,6 +428,16 @@ simplBinder bndr thing_inside
     setSubst subst' (thing_inside bndr')
 
 
+simplLamBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
+simplLamBinder bndr thing_inside
+  = getSubst           `thenSmpl` \ subst ->
+    let
+       (subst', bndr') = Subst.simplLamBndr subst bndr
+    in
+    seqBndr bndr'      `seq`
+    setSubst subst' (thing_inside bndr')
+
+
 simplRecIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 simplRecIds ids thing_inside
   = getSubst           `thenSmpl` \ subst ->

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 62389b7..ff64455 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -15,7 +15,7 @@ import CmdLineOpts    ( switchIsOn, opt_SimplDoEtaReduction,
                        )
 import SimplMonad
 import SimplUtils      ( mkCase, tryRhsTyLam, tryEtaExpansion,
-                         simplBinder, simplBinders, simplRecIds, simplLetId,
+                         simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinder,
                          SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
                          contResultType, discardInline, countArgs, contIsDupable,
                          getContArgs, interestingCallContext, interestingArg, isStrictType
@@ -46,7 +46,7 @@ import CoreUnfold     ( mkOtherCon, mkUnfolding, otherCons,
 import CoreUtils       ( cheapEqExpr, exprIsDupable, exprIsTrivial, 
                          exprIsConApp_maybe, mkPiType, findAlt, findDefault,
                          exprType, coreAltsType, exprIsValue, 
-                         exprOkForSpeculation, exprArity, exprIsCheap,
+                         exprOkForSpeculation, exprArity, 
                          mkCoerce, mkSCC, mkInlineMe, mkAltExpr
                        )
 import Rules           ( lookupRule )
@@ -293,7 +293,7 @@ simplLam fun cont
 -- to avoid allocating this thing altogether
 
 completeLam rev_bndrs (Lam bndr body) cont
-  = simplBinder bndr                   $ \ bndr' ->
+  = simplLamBinder bndr                        $ \ bndr' ->
     completeLam (bndr':rev_bndrs) body cont
 
 completeLam rev_bndrs body cont
@@ -733,14 +733,6 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
     let
        (floats2, rhs2) = splitFloats float_ubx floats1 rhs1
     in
-               -- There's a subtlety here.  There may be a binding (x* = e) in the
-               -- floats, where the '*' means 'will be demanded'.  So is it safe
-               -- to float it out?  Answer no, but it won't matter because
-               -- we only float if arg' is a WHNF,
-               -- and so there can't be any 'will be demanded' bindings in the floats.
-               -- Hence the assert
-    WARN( any demanded_float (fromOL floats2), ppr (filter demanded_float (fromOL floats2)) )
-
        --                      Transform the RHS
        -- It's important that we do eta expansion on function *arguments* (which are
        -- simplified with simplRhs), as well as let-bound right-hand sides.  
@@ -753,7 +745,25 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
 
        -- Float lets if (a) we're at the top level
        -- or            (b) the resulting RHS is one we'd like to expose
-    if (top_lvl || exprIsCheap rhs4) then
+       --
+       -- NB: the test used to say "exprIsValue", but that caused a strictness bug.
+       --         x = let y* = E in case (scc y) of { T -> F; F -> T}
+       -- The case expression is 'cheap', but it's wrong to transform to
+       --         y* = E; x = case (scc y) of {...}
+       -- Either we must be careful not to float demanded non-values, or
+       -- we must use exprIsValue for the test, which ensures that the
+       -- thing is non-strict.  I think.  The WARN below tests for this
+    if (top_lvl || exprIsValue rhs4) then
+
+               -- There's a subtlety here.  There may be a binding (x* = e) in the
+               -- floats, where the '*' means 'will be demanded'.  So is it safe
+               -- to float it out?  Answer no, but it won't matter because
+               -- we only float if arg' is a WHNF,
+               -- and so there can't be any 'will be demanded' bindings in the floats.
+               -- Hence the assert
+        WARN( any demanded_float (fromOL floats2), 
+             ppr (filter demanded_float (fromOL floats2)) )
+
        (if (isNilOL floats2 && null floats3 && null floats4) then
                returnSmpl ()
         else