Commit 596dece7 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Record evaluated-ness on workers and wrappers

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

  commit 6b976eb8
  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%
parent 729a5e45
......@@ -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
......
......@@ -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
{-
************************************************************************
......
......@@ -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
......
......@@ -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 #-}
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......@@ -820,10 +820,13 @@ test('T9961',
test('T9233',
[ only_ways(['normal']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 984268712, 5),
[(wordsize(64), 861862608, 5),
# 2015-08-04 999826288 initial value
# 2016-04-14 1066246248 Final demand analyzer run
# 2016-06-18 984268712 shuffling around of Data.Functor.Identity
# 2017-0123 861862608 worker/wrapper evald-ness flags; 10% improvement!
(wordsize(32), 515672240, 5) # Put in your value here if you hit this
# 2016-04-06 515672240 (x86/Linux) initial value
]),
......
{-# LANGUAGE MagicHash #-}
module T13077 where
import GHC.Exts
data X = A | B | C
data T = MkT !X Int# Int#
f (MkT x 0# _) = True
f (MkT x n _) = let v = case x of
A -> 1#
B -> 2#
C -> n
in f (MkT x v v)
-- Tests evaluatedness for worker args
{-# LANGUAGE MagicHash #-}
module T13077a where
import GHC.Exts
data X = A | B | C
data T = MkT !X Int# Int#
g :: Int -> T
g 0 = MkT A 1# 2#
g n = g (n-1)
boo :: Int -> T
boo k = case g k of
MkT x n _ -> let v = case x of
A -> 1#
B -> 2#
C -> n
in MkT x v v
-- Tests evaluated-ness for CPR
......@@ -52,4 +52,5 @@ test('T11770', [ checkCoreString('OneShot') ], compile, ['-ddump-simpl'])
test('T13031', normal, run_command,
['$MAKE -s --no-print-directory T13031'])
test('T13077', normal, compile, [''])
test('T13077a', normal, compile, [''])
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