Revert "Record evaluated-ness on workers and wrappers"

This reverts commit 6b976eb89fe72827f226506d16d3721ba4e28bab.

Ben, Ryan and I decided to revert this for now due to T12234 failing
and causing all harbormaster builds to fail.

4 files changed, 37 insertions, 101 deletions

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index d5fea9e287..84cafa3902 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -93,7 +93,7 @@ module Id (
         idOccInfo,
 
         -- ** Writing 'IdInfo' fields
-        setIdUnfolding, setCaseBndrEvald,
+        setIdUnfolding,
         setIdArity,
         setIdCallArity,
 
@@ -111,7 +111,7 @@ module Id (
 
 #include "HsVersions.h"
 
-import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) )
+import CoreSyn ( CoreRule, Unfolding( NoUnfolding ) )
 
 import IdInfo
 import BasicTypes
@@ -612,15 +612,6 @@ 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/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 9616e8d440..60024c5835 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -1595,10 +1595,12 @@ 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
-      = setCaseBndrEvald str $  -- See Note [Mark evaluated arguments]
-        mkLocalIdOrCoVar name (Type.substTy full_subst ty)
+      = mkLocalIdOrCoVarWithInfo name (Type.substTy full_subst ty) info
       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 72593e9ead..aaeb997b54 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -25,7 +25,8 @@ import Name             ( Name, mkSystemVarName, isExternalName, getOccFS )
 import Coercion hiding  ( substCo, substCoVar )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType_maybe )
-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepArgTys )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
+                        , isMarkedStrict, dataConRepArgTys ) --, dataConTyCon, dataConTag, fIRST_TAG )
 --import TyCon            ( isEnumerationTyCon ) -- temporalily commented out. See #8326
 import CoreMonad        ( Tick(..), SimplifierMode(..) )
 import CoreSyn
@@ -2127,7 +2128,9 @@ 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) = zap str v : go vs' strs
+          go (v:vs') (str:strs)
+            | isMarkedStrict str = eval v : go vs' strs
+            | otherwise          = zap v  : go vs' strs
           go _ _ = pprPanic "cat_evals"
                     (ppr con $$
                      ppr vs  $$
@@ -2140,9 +2143,8 @@ simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
                                     -- NB: If this panic triggers, note that
                                     -- NoStrictnessMark doesn't print!
 
-          zap str v = setCaseBndrEvald str $ -- Add eval'dness info
-                      zapIdOccInfo v         -- And kill occ info;
-                                             -- see Note [Case alternative occ info]
+          zap v  = zapIdOccInfo v   -- See Note [Case alternative occ info]
+          eval v = zap v `setIdUnfolding` evaldUnfolding
 
 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 65fa6d8474..1370bbce06 100644
--- a/compiler/stranal/WwLib.hs
+++ b/compiler/stranal/WwLib.hs
@@ -501,13 +501,14 @@ 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 = 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
+  =  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
          ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
                            -- Don't pass the arg, rebox instead
 
@@ -516,7 +517,6 @@ 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,47 +530,6 @@ 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
- * the arg binders x1,x2 in mkWstr_one
- * the result binders r1,r2 in mkWWcpr_help
-to record that the relevant binder is evaluated.
-
-See Trac #13027 comment:20, item (4).
-
-
 ************************************************************************
 *                                                                      *
          Type scrutiny that is specfic to demand analysis
@@ -598,33 +557,23 @@ increase closure sizes.
 Conclusion: don't unpack dictionaries.
 -}
 
-deepSplitProductType_maybe
-    :: FamInstEnvs -> Type
-    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
+deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe (DataCon, [Type], [Type], 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]
-  , let arg_tys = dataConInstArgTys con tc_args
-        strict_marks = dataConRepStrictness con
-  = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)
+  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
 deepSplitProductType_maybe _ _ = Nothing
 
-deepSplitCprType_maybe
-    :: FamInstEnvs -> ConTag -> Type
-    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
+deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe (DataCon, [Type], [Type], 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)
@@ -633,10 +582,8 @@ 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)
-        arg_tys = dataConInstArgTys con tc_args
-        strict_marks = dataConRepStrictness con
-  = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)
+  , let con  = cons `getNth` (con_tag - fIRST_TAG)
+  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
 deepSplitCprType_maybe _ _ _ = Nothing
 
 findTypeShape :: FamInstEnvs -> Type -> TypeShape
@@ -700,18 +647,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,StrictnessMark)], Coercion)
+mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
              -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
 
 mkWWcpr_help (data_con, inst_tys, arg_tys, co)
-  | [arg1@(arg_ty1, _)] <- arg_tys
+  | [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 arg1
+       ; let arg       = mk_ww_local arg_uniq  arg_ty1
              con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
 
        ; return ( True
@@ -724,12 +671,11 @@ 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 : 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
+  = 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
 
        ; return (True
                 , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]
@@ -748,7 +694,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, MarkedStrict)
+    bndr = mk_ww_local uniq (exprType casted_scrut)
 
 {-
 Note [non-algebraic or open body type warning]
@@ -860,10 +806,5 @@ sanitiseCaseBndr :: Id -> Id
 -- like         (x+y) `seq` ....
 sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
 
-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
+mk_ww_local :: Unique -> Type -> Id
+mk_ww_local uniq ty = mkSysLocalOrCoVar (fsLit "ww") uniq ty