Commit 1f48fbc9 authored by Matthew Pickering's avatar Matthew Pickering

Revert "Record evaluated-ness on workers and wrappers"

This reverts commit 6b976eb8.

Ben, Ryan and I decided to revert this for now due to T12234 failing
and causing all harbormaster builds to fail.
parent c13151e5
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment