import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
- idSpecialisation, setIdSpecialisation,
setIdOccInfo, zapLamIdInfo, setOneShotLambda,
)
import OccName ( encodeFS )
import IdInfo ( OccInfo(..), isLoopBreaker,
- setArityInfo,
+ setArityInfo, zapDemandInfo,
setUnfoldingInfo,
occInfo
)
import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy,
splitFunTy_maybe, splitFunTy, eqType
)
-import Subst ( mkSubst, substTy, substExpr, substRules,
+import Subst ( mkSubst, substTy, substExpr,
isInScope, lookupIdSubst, simplIdInfo
)
import TysPrim ( realWorldStatePrimTy )
)
import OrdList
import Maybe ( Maybe )
+import Maybes ( orElse )
import Outputable
import Util ( notNull )
\end{code}
if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
completeLazyBind env1 top_lvl bndr bndr2 rhs2
- -- We use exprIsTrivial here because we want to reveal lone variables.
- -- E.g. let { x = letrec { y = E } in y } in ...
- -- Here we definitely want to float the y=E defn.
- -- exprIsValue definitely isn't right for that.
- --
- -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
+ else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+ -- WARNING: long dodgy argument coming up
+ -- WANTED: a better way to do this
+ --
+ -- We can't use "exprIsCheap" instead of exprIsValue,
+ -- because that causes 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.
- else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+ -- thing is non-strict. So exprIsValue => bindings are non-strict
+ -- I think. The WARN below tests for this.
+ --
+ -- We use exprIsTrivial here because we want to reveal lone variables.
+ -- E.g. let { x = letrec { y = E } in y } in ...
+ -- Here we definitely want to float the y=E defn.
+ -- exprIsValue definitely isn't right for that.
+ --
+ -- Again, the floated binding can't be strict; if it's recursive it'll
+ -- be non-strict; if it's non-recursive it'd be inlined.
+ --
+ -- Note [SCC-and-exprIsTrivial]
+ -- If we have
+ -- y = let { x* = E } in scc "foo" x
+ -- then we do *not* want to float out the x binding, because
+ -- it's strict! Fortunately, exprIsTrivial replies False to
+ -- (scc "foo" x).
-- 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
-- we only float if (a) arg' is a WHNF, or (b) it's going to top level
-- and so there can't be any 'will be demanded' bindings in the floats.
-- Hence the warning
- WARN( not is_top_level && any demanded_float (floatBinds floats),
- ppr (filter demanded_float (floatBinds floats)) )
+ ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)),
+ ppr (filter demanded_float (floatBinds floats)) )
tick LetFloatFromLet `thenSmpl_` (
addFloats env1 floats $ \ env2 ->
-- Add arity info
new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
- -- Add the unfolding *only* for non-loop-breakers
- -- Making loop breakers not have an unfolding at all
- -- means that we can avoid tests in exprIsConApp, for example.
- -- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing, then we can get into an infinite loop
- info_w_unf | loop_breaker = new_bndr_info
- | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
- unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
-
- final_id = new_bndr `setIdInfo` info_w_unf
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+
+ -- If the unfolding is a value, the demand info may
+ -- go pear-shaped, so we nuke it. Example:
+ -- let x = (a,b) in
+ -- case x of (p,q) -> h p q x
+ -- Here x is certainly demanded. But after we've nuked
+ -- the case, we'll get just
+ -- let x = (a,b) in h a b x
+ -- and now x is not demanded (I'm assuming h is lazy)
+ -- This really happens. Similarly
+ -- let f = \x -> e in ...f..f...
+ -- After inling f at some of its call sites the original binding may
+ -- (for example) be no longer strictly demanded.
+ -- The solution here is a bit ad hoc...
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+ info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
+ final_info | loop_breaker = new_bndr_info
+ | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
+ | otherwise = info_w_unf
+
+ final_id = new_bndr `setIdInfo` final_info
in
-- These seqs forces the Id, and hence its IdInfo,
-- and hence any inner substitutions
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
- add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc)
+ add_evals (DataAlt dc) vs = cat_evals dc vs (dataConRepStrictness dc)
add_evals other_con vs = vs
- cat_evals [] [] = []
- cat_evals (v:vs) (str:strs)
- | isTyVar v = v : cat_evals vs (str:strs)
- | isMarkedStrict str = evald_v : cat_evals vs strs
- | otherwise = zapped_v : cat_evals vs strs
+ cat_evals dc vs strs
+ = go vs strs
where
- zapped_v = zap_occ_info v
- evald_v = zapped_v `setIdUnfolding` mkOtherCon []
+ go [] [] = []
+ go (v:vs) (str:strs)
+ | isTyVar v = v : go vs (str:strs)
+ | isMarkedStrict str = evald_v : go vs strs
+ | otherwise = zapped_v : go vs strs
+ where
+ zapped_v = zap_occ_info v
+ evald_v = zapped_v `setIdUnfolding` mkOtherCon []
+ go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
\end{code}
projects / ghc-hetmet.git / blobdiff