From: simonpj Date: Mon, 10 Sep 2001 07:24:09 +0000 (+0000) Subject: [project @ 2001-09-10 07:24:09 by simonpj] X-Git-Tag: Approximately_9120_patches~1003 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2aa5738fe61869f239672d8e10e8ecb6fc108b47;p=ghc-hetmet.git [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 --- 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 --- 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