\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecIds, simplLetId,
+ simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinder,
tryRhsTyLam, tryEtaExpansion,
mkCase,
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 )
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 ->
)
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
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 )
-- 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
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.
-- 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