Record evaluated-ness on workers and wrappers

Summary:
This patch is a refinement of the original commit (which
was reverted):

  commit 6b976eb89fe72827f226506d16d3721ba4e28bab
  Date:   Fri Jan 13 08:56:53 2017 +0000
      Record evaluated-ness on workers and wrappers

In Trac #13027, comment:20, I noticed that wrappers created after
demand analysis weren't recording the evaluated-ness of strict
constructor arguments.  In the ticket that led to a (debatable)
Lint error but in general the more we know about evaluated-ness
the better we can optimise.

This commit adds that info
  * both in the worker (on args)
  * and in the wrapper (on CPR result patterns).
See Note [Record evaluated-ness in worker/wrapper] in WwLib

On the way I defined Id.setCaseBndrEvald, and used it to shorten
the code in a few other places

Then I added test T13077a to test the CPR aspect of this patch,
but I found that Lint failed!

Reason: simpleOptExpr was discarding evaluated-ness info on
lambda binders because zapFragileIdInfo was discarding an
Unfolding of (OtherCon _).  But actually that's a robust
unfolding; there is no need to discard it. To fix this:

* zapFragileIdInfo only zaps fragile unfoldings

* Replace isClosedUnfolding with isFragileUnfolding (the latter
  is just the negation of the former, but the nomenclature is
  more consistent).  Better documentation too
       Note [Fragile unfoldings]

* And Simplify.simplLamBndr can now look at isFragileUnfolding
  to decide whether to use the longer route of simplUnfolding.

For some reason perf/compiler/T9233 improves in compile-time
allocation by 10%.  Hooray

Nofib: essentially no change:

--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
      cacheprof          +0.0%     -0.3%     +0.9%     +0.4%     +0.0%
--------------------------------------------------------------------------------
            Min          +0.0%     -0.3%     -2.4%     -2.4%     +0.0%
            Max          +0.0%     +0.0%     +9.8%    +11.4%     +2.4%
 Geometric Mean          +0.0%     -0.0%     +1.1%     +1.0%     +0.0%

7 files changed, 150 insertions, 59 deletions

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index bab8caf017..2b1bdfd51b 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -94,7 +94,7 @@ module Id (
         isNeverLevPolyId,
 
         -- ** Writing 'IdInfo' fields
-        setIdUnfolding,
+        setIdUnfolding, setCaseBndrEvald,
         setIdArity,
         setIdCallArity,
 
@@ -112,7 +112,7 @@ module Id (
 
 #include "HsVersions.h"
 
-import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) )
+import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) )
 
 import IdInfo
 import BasicTypes
@@ -617,6 +617,15 @@ idDemandInfo       id = demandInfo (idInfo id)
 setIdDemandInfo :: Id -> Demand -> Id
 setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id
 
+setCaseBndrEvald :: StrictnessMark -> Id -> Id
+-- Used for variables bound by a case expressions, both the case-binder
+-- itself, and any pattern-bound variables that are argument of a
+-- strict constructor.  It just marks the variable as already-evaluated,
+-- so that (for example) a subsequent 'seq' can be dropped
+setCaseBndrEvald str id
+  | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding
+  | otherwise          = id
+
         ---------------------------------
         -- SPECIALISATION
 
diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs
index b36432646f..44815393e3 100644
--- a/compiler/basicTypes/IdInfo.hs
+++ b/compiler/basicTypes/IdInfo.hs
@@ -514,12 +514,20 @@ zapUsedOnceInfo info
 
 zapFragileInfo :: IdInfo -> Maybe IdInfo
 -- ^ Zap info that depends on free variables
-zapFragileInfo info
-  = Just (info `setRuleInfo` emptyRuleInfo
-               `setUnfoldingInfo` noUnfolding
-               `setOccInfo` zapFragileOcc occ)
+zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf })
+  = new_unf `seq`  -- The unfolding field is not (currently) strict, so we
+                   -- force it here to avoid a (zapFragileUnfolding unf) thunk
+                   -- which might leak space
+    Just (info `setRuleInfo` emptyRuleInfo
+               `setUnfoldingInfo` new_unf
+               `setOccInfo`       zapFragileOcc occ)
   where
-    occ = occInfo info
+    new_unf = zapFragileUnfolding unf
+
+zapFragileUnfolding :: Unfolding -> Unfolding
+zapFragileUnfolding unf
+ | isFragileUnfolding unf = noUnfolding
+ | otherwise              = unf
 
 {-
 ************************************************************************
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index 758a17b34d..72df704e1c 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -640,8 +640,7 @@ substIdInfo subst new_id info
   where
     old_rules     = ruleInfo info
     old_unf       = unfoldingInfo info
-    nothing_to_do = isEmptyRuleInfo old_rules && isClosedUnfolding old_unf
-
+    nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf)
 
 ------------------
 -- | Substitutes for the 'Id's within an unfolding
@@ -1104,8 +1103,10 @@ subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
   where
     id1    = uniqAway in_scope old_id
     id2    = setIdType id1 (substTy subst (idType old_id))
-    new_id = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding
-                                        -- and fragile OccInfo
+    new_id = zapFragileIdInfo id2
+             -- Zaps rules, worker-info, unfolding, and fragile OccInfo
+             -- The unfolding and rules will get added back later, by add_info
+
     new_in_scope = in_scope `extendInScopeSet` new_id
 
         -- Extend the substitution if the unique has changed,
@@ -1126,7 +1127,8 @@ add_info :: Subst -> InVar -> OutVar -> OutVar
 add_info subst old_bndr new_bndr
  | isTyVar old_bndr = new_bndr
  | otherwise        = maybeModifyIdInfo mb_new_info new_bndr
- where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
+ where
+   mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
 
 simpleUnfoldingFun :: IdUnfoldingFun
 simpleUnfoldingFun id
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 4dfd9c3dae..bcf9e6eb4d 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -64,8 +64,7 @@ module CoreSyn (
         maybeUnfoldingTemplate, otherCons,
         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
-        isStableUnfolding,
-        isClosedUnfolding, hasSomeUnfolding,
+        isStableUnfolding, isFragileUnfolding, hasSomeUnfolding,
         isBootUnfolding,
         canUnfold, neverUnfoldGuidance, isStableSource,
 
@@ -1159,7 +1158,7 @@ data UnfoldingSource
                        -- to the current RHS during compilation as with
                        -- InlineRhs.
                        --
-                       -- See Note [InlineRules]
+                       -- See Note [InlineStable]
 
   | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
                        -- Only a few primop-like things have this property
@@ -1350,11 +1349,6 @@ isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
 isStableUnfolding (DFunUnfolding {})               = True
 isStableUnfolding _                                = False
 
-isClosedUnfolding :: Unfolding -> Bool          -- No free variables
-isClosedUnfolding (CoreUnfolding {}) = False
-isClosedUnfolding (DFunUnfolding {}) = False
-isClosedUnfolding _                  = True
-
 -- | Only returns False if there is no unfolding information available at all
 hasSomeUnfolding :: Unfolding -> Bool
 hasSomeUnfolding NoUnfolding   = False
@@ -1369,12 +1363,34 @@ neverUnfoldGuidance :: UnfoldingGuidance -> Bool
 neverUnfoldGuidance UnfNever = True
 neverUnfoldGuidance _        = False
 
+isFragileUnfolding :: Unfolding -> Bool
+-- An unfolding is fragile if it mentions free variables or
+-- is otherwise subject to change.  A robust one can be kept.
+-- See Note [Fragile unfoldings]
+isFragileUnfolding (CoreUnfolding {}) = True
+isFragileUnfolding (DFunUnfolding {}) = True
+isFragileUnfolding _                  = False
+  -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile
+
 canUnfold :: Unfolding -> Bool
 canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
 canUnfold _                                   = False
 
-{-
-Note [InlineRules]
+{- Note [Fragile unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An unfolding is "fragile" if it mentions free variables (and hence would
+need substitution) or might be affeceted by optimisation.  The non-fragile
+ones are
+
+   NoUnfolding, BootUnfolding
+
+   OtherCon {}    If we know this binder (say a lambda binder) will be
+                  bound to an evaluated thing, we weant to retain that
+                  info in simpleOptExpr; see Trac #13077.
+
+We consider even a StableUnfolding as fragile, because it needs substitution.
+
+Note [InlineStable]
 ~~~~~~~~~~~~~~~~~
 When you say
       {-# INLINE f #-}
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index b5d248e579..d8e34adffb 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -1673,12 +1673,10 @@ dataConInstPat fss uniqs con inst_tys
       -- Make value vars, instantiating types
     arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs
     mk_id_var uniq fs ty str
-      = mkLocalIdOrCoVarWithInfo name (Type.substTy full_subst ty) info
+      = setCaseBndrEvald str $  -- See Note [Mark evaluated arguments]
+        mkLocalIdOrCoVar name (Type.substTy full_subst ty)
       where
         name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan
-        info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding
-             | otherwise          = vanillaIdInfo
-             -- See Note [Mark evaluated arguments]
 
 {-
 Note [Mark evaluated arguments]
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 9e5c00d284..c1f2a9f705 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -25,8 +25,7 @@ import Name             ( Name, mkSystemVarName, isExternalName, getOccFS )
 import Coercion hiding  ( substCo, substCoVar )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType_maybe )
-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
-                        , isMarkedStrict, dataConRepArgTys ) --, dataConTyCon, dataConTag, fIRST_TAG )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepArgTys )
 --import TyCon            ( isEnumerationTyCon ) -- temporalily commented out. See #8326
 import CoreMonad        ( Tick(..), SimplifierMode(..) )
 import CoreSyn
@@ -1261,7 +1260,7 @@ simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
 
 -------------
-simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 -- Used for lambda binders.  These sometimes have unfoldings added by
 -- the worker/wrapper pass that must be preserved, because they can't
 -- be reconstructed from context.  For example:
@@ -1269,7 +1268,7 @@ simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
 --      fw a b x{=(a,b)} = ...
 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
 simplLamBndr env bndr
-  | isId bndr && hasSomeUnfolding old_unf   -- Special case
+  | isId bndr && isFragileUnfolding old_unf   -- Special case
   = do { (env1, bndr1) <- simplBinder env bndr
        ; unf'          <- simplUnfolding env1 NotTopLevel bndr old_unf
        ; let bndr2 = bndr1 `setIdUnfolding` unf'
@@ -2136,9 +2135,7 @@ simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
         where
           go [] [] = []
           go (v:vs') strs | isTyVar v = v : go vs' strs
-          go (v:vs') (str:strs)
-            | isMarkedStrict str = eval v : go vs' strs
-            | otherwise          = zap v  : go vs' strs
+          go (v:vs') (str:strs) = zap str v : go vs' strs
           go _ _ = pprPanic "cat_evals"
                     (ppr con $$
                      ppr vs  $$
@@ -2151,8 +2148,9 @@ simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
                                     -- NB: If this panic triggers, note that
                                     -- NoStrictnessMark doesn't print!
 
-          zap v  = zapIdOccInfo v   -- See Note [Case alternative occ info]
-          eval v = zap v `setIdUnfolding` evaldUnfolding
+          zap str v = setCaseBndrEvald str $ -- Add eval'dness info
+                      zapIdOccInfo v         -- And kill occ info;
+                                             -- see Note [Case alternative occ info]
 
 addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
 addAltUnfoldings env scrut case_bndr con_app
diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs
index 9e9f4a143a..fd0826c5fd 100644
--- a/compiler/stranal/WwLib.hs
+++ b/compiler/stranal/WwLib.hs
@@ -501,14 +501,13 @@ mkWWstr_one dflags fam_envs arg
              <- deepSplitProductType_maybe fam_envs (idType arg)
   , cs `equalLength` inst_con_arg_tys
       -- See Note [mkWWstr and unsafeCoerce]
-  =  do { (uniq1:uniqs) <- getUniquesM
-        ; let   unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
-                unpk_args_w_ds = zipWithEqual "mkWWstr" setIdDemandInfo unpk_args cs
-                unbox_fn       = mkUnpackCase (Var arg) co uniq1
-                                              data_con unpk_args
-                rebox_fn       = Let (NonRec arg con_app)
-                con_app        = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
-         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args_w_ds
+  = do { (uniq1:uniqs) <- getUniquesM
+        ; let   unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs
+                unbox_fn  = mkUnpackCase (Var arg) co uniq1
+                                         data_con unpk_args
+                rebox_fn  = Let (NonRec arg con_app)
+                con_app   = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args
          ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
                            -- Don't pass the arg, rebox instead
 
@@ -517,6 +516,7 @@ mkWWstr_one dflags fam_envs arg
 
   where
     dmd = idDemandInfo arg
+    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd
 
 ----------------------
 nop_fn :: CoreExpr -> CoreExpr
@@ -530,6 +530,48 @@ match the number of constructor arguments; this happened in Trac #8037.
 If so, the worker/wrapper split doesn't work right and we get a Core Lint
 bug.  The fix here is simply to decline to do w/w if that happens.
 
+Note [Record evaluated-ness in worker/wrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   data T = MkT !Int Int
+
+   f :: T -> T
+   f x = e
+
+and f's is strict, and has the CPR property.  The we are going to generate
+this w/w split
+
+   f x = case x of
+           MkT x1 x2 -> case $wf x1 x2 of
+                           (# r1, r2 #) -> MkT r1 r2
+
+   $wfw x1 x2 = let x = MkT x1 x2 in
+                case e of
+                  MkT r1 r2 -> (# r1, r2 #)
+
+Note that
+
+* In the worker $wf, inside 'e' we can be sure that x1 will be
+  evaluated (it came from unpacking the argument MkT.  But that's no
+  immediately apparent in $wf
+
+* In the wrapper 'f', which we'll inline at call sites, we can be sure
+  that 'r1' has been evaluated (because it came from unpacking the result
+  MkT.  But that is not immediately apparent from the wrapper code.
+
+Missing these facts isn't unsound, but it loses possible future
+opportunities for optimisation.
+
+Solution: use setCaseBndrEvald when creating
+ (A) The arg binders x1,x2 in mkWstr_one
+         See Trac #13077, test T13077
+ (B) The result binders r1,r2 in mkWWcpr_help
+         See Trace #13077, test T13077a
+         And Trac #13027 comment:20, item (4)
+to record that the relevant binder is evaluated.
+
+
 ************************************************************************
 *                                                                      *
          Type scrutiny that is specific to demand analysis
@@ -557,23 +599,33 @@ increase closure sizes.
 Conclusion: don't unpack dictionaries.
 -}
 
-deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
+deepSplitProductType_maybe
+    :: FamInstEnvs -> Type
+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
 -- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
 -- then  dc @ tys (args::arg_tys) :: rep_ty
 --       co :: ty ~ rep_ty
+-- Why do we return the strictness of the data-con arguments?
+-- Answer: see Note [Record evaluated-ness in worker/wrapper]
 deepSplitProductType_maybe fam_envs ty
   | let (co, ty1) = topNormaliseType_maybe fam_envs ty
                     `orElse` (mkRepReflCo ty, ty)
   , Just (tc, tc_args) <- splitTyConApp_maybe ty1
   , Just con <- isDataProductTyCon_maybe tc
   , not (isClassTyCon tc)  -- See Note [Do not unpack class dictionaries]
-  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
+  , let arg_tys = dataConInstArgTys con tc_args
+        strict_marks = dataConRepStrictness con
+  = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)
 deepSplitProductType_maybe _ _ = Nothing
 
-deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
+deepSplitCprType_maybe
+    :: FamInstEnvs -> ConTag -> Type
+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
 -- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
 -- then  dc @ tys (args::arg_tys) :: rep_ty
 --       co :: ty ~ rep_ty
+-- Why do we return the strictness of the data-con arguments?
+-- Answer: see Note [Record evaluated-ness in worker/wrapper]
 deepSplitCprType_maybe fam_envs con_tag ty
   | let (co, ty1) = topNormaliseType_maybe fam_envs ty
                     `orElse` (mkRepReflCo ty, ty)
@@ -582,8 +634,10 @@ deepSplitCprType_maybe fam_envs con_tag ty
   , let cons = tyConDataCons tc
   , cons `lengthAtLeast` con_tag -- This might not be true if we import the
                                  -- type constructor via a .hs-bool file (#8743)
-  , let con  = cons `getNth` (con_tag - fIRST_TAG)
-  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
+  , let con = cons `getNth` (con_tag - fIRST_TAG)
+        arg_tys = dataConInstArgTys con tc_args
+        strict_marks = dataConRepStrictness con
+  = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)
 deepSplitCprType_maybe _ _ _ = Nothing
 
 findTypeShape :: FamInstEnvs -> Type -> TypeShape
@@ -647,18 +701,18 @@ mkWWcpr opt_CprAnal fam_envs body_ty res
                     -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
                        return (False, id, id, body_ty)
 
-mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
+mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)
              -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
 
 mkWWcpr_help (data_con, inst_tys, arg_tys, co)
-  | [arg_ty1] <- arg_tys
+  | [arg1@(arg_ty1, _)] <- arg_tys
   , isUnliftedType arg_ty1
         -- Special case when there is a single result of unlifted type
         --
         -- Wrapper:     case (..call worker..) of x -> C x
         -- Worker:      case (   ..body..    ) of C x -> x
   = do { (work_uniq : arg_uniq : _) <- getUniquesM
-       ; let arg       = mk_ww_local arg_uniq  arg_ty1
+       ; let arg       = mk_ww_local arg_uniq arg1
              con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
 
        ; return ( True
@@ -671,11 +725,12 @@ mkWWcpr_help (data_con, inst_tys, arg_tys, co)
   | otherwise   -- The general case
         -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
         -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)
-  = do { (work_uniq : uniqs) <- getUniquesM
-       ; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys)
-             ubx_tup_ty   = exprType ubx_tup_app
-             ubx_tup_app  = mkCoreUbxTup arg_tys (map varToCoreExpr args)
-             con_app      = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
+  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM
+       ; let wrap_wild   = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)
+             args        = zipWith mk_ww_local uniqs arg_tys
+             ubx_tup_ty  = exprType ubx_tup_app
+             ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)
+             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
 
        ; return (True
                 , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]
@@ -694,7 +749,7 @@ mkUnpackCase scrut co uniq boxing_con unpk_args body
          [(DataAlt boxing_con, unpk_args, body)]
   where
     casted_scrut = scrut `mkCast` co
-    bndr = mk_ww_local uniq (exprType casted_scrut)
+    bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)
 
 {-
 Note [non-algebraic or open body type warning]
@@ -806,5 +861,10 @@ sanitiseCaseBndr :: Id -> Id
 -- like         (x+y) `seq` ....
 sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
 
-mk_ww_local :: Unique -> Type -> Id
-mk_ww_local uniq ty = mkSysLocalOrCoVar (fsLit "ww") uniq ty
+mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id
+-- The StrictnessMark comes form the data constructor and says
+-- whether this field is strict
+-- See Note [Record evaluated-ness in worker/wrapper]
+mk_ww_local uniq (ty,str)
+  = setCaseBndrEvald str $
+    mkSysLocalOrCoVar (fsLit "ww") uniq ty