Record evaluated-ness information correctly for strict constructors

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.

2 files changed, 18 insertions, 16 deletions

diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 762758fadf..10e243c058 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -519,18 +519,19 @@ simplBinder env bndr
 -------------
 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
-  | 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
-    (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)
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 9723dfb701..baf2a3097a 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1572,19 +1572,19 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
 
 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.
-	; 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')
-	      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'
-	; 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
@@ -1595,9 +1595,7 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
 	-- 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
+    add_evals vs strs
 	= go vs strs
 	where
 	  go [] [] = []
@@ -1608,12 +1606,15 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs)
 	    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
-	-- 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