Commit 2aa5738f authored by simonpj's avatar simonpj
Browse files

[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.
parent 8968073e
......@@ -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 ->
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment