The add_evals code in Simplify.simplAlt had bit-rotted. Example:
data T a = T !a
data U a = U !a
foo :: T a -> U a
foo (T x) = U x
Here we should not evaluate x before building the U result, because
the x argument of T is already evaluated.
Thanks to Roman for finding this.
-------------
simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
-- Used for lambda binders. These sometimes have unfoldings added by
-------------
simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
-- Used for lambda binders. These sometimes have unfoldings added by
--- the worker/wrapper pass that must be preserved, becuase they can't
+-- the worker/wrapper pass that must be preserved, because they can't
-- be reconstructed from context. For example:
-- f x = case x of (a,b) -> fw a b x
-- fw a b x{=(a,b)} = ...
-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
simplLamBndr env bndr
-- be reconstructed from context. For example:
-- f x = case x of (a,b) -> fw a b x
-- fw a b x{=(a,b)} = ...
-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
simplLamBndr env bndr
- | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case
- | otherwise = seqId id2 `seq` return (env', id2)
+ | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
+ | otherwise = seqId id1 `seq` return (env1, id1) -- Normal case
where
old_unf = idUnfolding bndr
where
old_unf = idUnfolding bndr
- (env', id1) = substIdBndr env bndr
- id2 = id1 `setIdUnfolding` substUnfolding env old_unf
+ (env1, id1) = substIdBndr env bndr
+ id2 = id1 `setIdUnfolding` substUnfolding env old_unf
+ env2 = modifyInScope env1 id1 id2
---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
= do { -- Deal with the pattern-bound variables
simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
= do { -- Deal with the pattern-bound variables
- (env, vs') <- simplBinders env (add_evals con vs)
-
-- Mark the ones that are in ! positions in the
-- data constructor as certainly-evaluated.
-- Mark the ones that are in ! positions in the
-- data constructor as certainly-evaluated.
- ; let vs'' = add_evals con vs'
+ -- NB: simplLamBinders preserves this eval info
+ let vs_with_evals = add_evals vs (dataConRepStrictness con)
+ ; (env, vs') <- simplLamBndrs env vs_with_evals
-- Bind the case-binder to (con args)
; let inst_tys' = tyConAppArgs (idType case_bndr')
-- Bind the case-binder to (con args)
; let inst_tys' = tyConAppArgs (idType case_bndr')
- con_args = map Type inst_tys' ++ varsToCoreExprs vs''
+ con_args = map Type inst_tys' ++ varsToCoreExprs vs'
env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
; rhs' <- simplExprC env' rhs cont'
env' = addBinderUnfolding env case_bndr' (mkConApp con con_args)
; rhs' <- simplExprC env' rhs cont'
- ; return (DataAlt con, vs'', rhs') }
+ ; return (DataAlt con, vs', rhs') }
where
-- add_evals records the evaluated-ness of the bound variables of
-- a case pattern. This is *important*. Consider
where
-- add_evals records the evaluated-ness of the bound variables of
-- a case pattern. This is *important*. Consider
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
-- See Note [Data-con worker strictness] in MkId.lhs
-- We really must record that b is already evaluated so that we don't
-- go and re-evaluate it when constructing the result.
-- See Note [Data-con worker strictness] in MkId.lhs
- add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc)
-
- cat_evals dc vs strs
= go vs strs
where
go [] [] = []
= go vs strs
where
go [] [] = []
where
zapped_v = zap_occ_info v
evald_v = zapped_v `setIdUnfolding` evaldUnfolding
where
zapped_v = zap_occ_info v
evald_v = zapped_v `setIdUnfolding` evaldUnfolding
- go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
+ go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr strs)
- -- If the case binder is alive, then we add the unfolding
+ -- zap_occ_info: if the case binder is alive, then we add the unfolding
-- case_bndr = C vs
-- to the envt; so vs are now very much alive
-- case_bndr = C vs
-- to the envt; so vs are now very much alive
- -- Note [Aug06] I can't see why this actually matters
+ -- Note [Aug06] I can't see why this actually matters, but it's neater
+ -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... }
+ -- ==> case e of t { (a,b) -> ...(a)... }
+ -- Look, Ma, a is alive now.
zap_occ_info | isDeadBinder case_bndr' = \id -> id
| otherwise = zapOccInfo
zap_occ_info | isDeadBinder case_bndr' = \id -> id
| otherwise = zapOccInfo
projects / ghc-hetmet.git / commitdiff