[Git][ghc/ghc][wip/T18328] Make arityType deal with join points
Simon Peyton Jones
gitlab at gitlab.haskell.org
Thu Jun 18 12:36:11 UTC 2020
Simon Peyton Jones pushed to branch wip/T18328 at Glasgow Haskell Compiler / GHC
Commits:
5bccde02 by Simon Peyton Jones at 2020-06-18T13:34:54+01:00
Make arityType deal with join points
As Note [Eta-expansion and join points] describes,
this patch makes arityType deal correctly with join points.
What was there before was not wrong, but yielded lower
arities than it could.
Fixes #18328
In base GHC this makes no difference to nofib.
Program Size Allocs Runtime Elapsed TotalMem
--------------------------------------------------------------------------------
n-body -0.1% -0.1% -1.2% -1.1% 0.0%
--------------------------------------------------------------------------------
Min -0.1% -0.1% -55.0% -56.5% 0.0%
Max -0.0% 0.0% +16.1% +13.4% 0.0%
Geometric Mean -0.0% -0.0% -30.1% -31.0% -0.0%
But it starts to make real difference when we land the change to the
way mkDupableAlts handles StrictArg, in fixing #13253 and friends.
I think this is because we then get more non-inlined join points.
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- + testsuite/tests/simplCore/should_compile/T18328.hs
- + testsuite/tests/simplCore/should_compile/T18328.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Core.Type as Type
import GHC.Core.TyCon ( initRecTc, checkRecTc )
import GHC.Core.Predicate ( isDictTy )
import GHC.Core.Coercion as Coercion
+import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Unique
import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )
@@ -155,7 +156,9 @@ exprBotStrictness_maybe e
Nothing -> Nothing
Just ar -> Just (ar, sig ar)
where
- env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
+ env = AE { ae_ped_bot = True
+ , ae_cheap_fn = \ _ _ -> False
+ , ae_joins = emptyVarSet }
sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv
{-
@@ -505,7 +508,8 @@ exprEtaExpandArity dflags e
ABot n -> n
where
env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp
- , ae_ped_bot = gopt Opt_PedanticBottoms dflags }
+ , ae_ped_bot = gopt Opt_PedanticBottoms dflags
+ , ae_joins = emptyVarSet }
getBotArity :: ArityType -> Maybe Arity
-- Arity of a divergent function
@@ -577,7 +581,8 @@ findRhsArity dflags bndr rhs old_arity
ATop _ -> (0, False) -- Note [Eta expanding thunks]
where
env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
- , ae_ped_bot = gopt Opt_PedanticBottoms dflags }
+ , ae_ped_bot = gopt Opt_PedanticBottoms dflags
+ , ae_joins = emptyVarSet }
{-
Note [Arity analysis]
@@ -735,8 +740,15 @@ type CheapFun = CoreExpr -> Maybe Type -> Bool
data ArityEnv
= AE { ae_cheap_fn :: CheapFun
, ae_ped_bot :: Bool -- True <=> be pedantic about bottoms
+ , ae_joins :: IdSet -- In-scope join points
+ -- See Note [Eta-expansion and join points]
}
+extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv
+extendJoinEnv env@(AE { ae_joins = joins }) join_ids
+ = env { ae_joins = joins `extendVarSetList` join_ids }
+
+----------------
arityType :: ArityEnv -> CoreExpr -> ArityType
arityType env (Cast e co)
@@ -754,7 +766,10 @@ arityType env (Cast e co)
-- However, do make sure that ATop -> ATop and ABot -> ABot!
-- Casts don't affect that part. Getting this wrong provoked #5475
-arityType _ (Var v)
+arityType env (Var v)
+ | v `elemVarSet` ae_joins env
+ = ABot 0 -- See Note [Eta-expansion and join points]
+
| strict_sig <- idStrictness v
, not $ isTopSig strict_sig
, (ds, res) <- splitStrictSig strict_sig
@@ -803,6 +818,28 @@ arityType env (Case scrut _ _ alts)
where
alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]
+arityType env (Let (NonRec j rhs) body)
+ | Just join_arity <- isJoinId_maybe j
+ , (_, rhs_body) <- collectNBinders join_arity rhs
+ = -- See Note [Eta-expansion and join points]
+ andArityType (arityType env rhs_body)
+ (arityType env' body)
+ where
+ env' = extendJoinEnv env [j]
+
+arityType env (Let (Rec pairs) body)
+ | ((j,_):_) <- pairs
+ , isJoinId j
+ = -- See Note [Eta-expansion and join points]
+ foldr (andArityType . do_one) (arityType env' body) pairs
+ where
+ env' = extendJoinEnv env (map fst pairs)
+ do_one (j,rhs)
+ | Just arity <- isJoinId_maybe j
+ = arityType env' $ snd $ collectNBinders arity rhs
+ | otherwise
+ = pprPanic "arityType:joinrec" (ppr pairs)
+
arityType env (Let b e)
= floatIn (cheap_bind b) (arityType env e)
where
@@ -815,6 +852,58 @@ arityType env (Tick t e)
arityType _ _ = vanillaArityType
+{- Note [Eta-expansion and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#18328)
+
+ f x = join j y = case y of
+ True -> \a. blah
+ False -> \b. blah
+ in case x of
+ A -> j True
+ B -> \c. blah
+ C -> j False
+
+and suppose the join point is too big to inline. Now, what is the
+arity of f? If we inlined the join point, we'd definitely say "arity
+2" because we are prepared to push case-scrutinisation inside a
+lambda. But currently the join point totally messes all that up,
+because (thought of as a vanilla let-binding) the arity pinned on 'j'
+is just 1.
+
+Why don't we eta-expand j? Because of
+Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils
+
+Even if we don't eta-expand j, why is its arity only 1?
+See invariant 2b in Note [Invariants on join points] in GHC.Core.
+
+So we do this:
+
+* Treat the RHS of a join-point binding, /after/ stripping off
+ join-arity lambda-binders, as very like the body of the let.
+ More precisely, do andArityType with the arityType from the
+ body of the let.
+
+* Dually, when we come to a /call/ of a join point, just no-op
+ by returning (ABot 0), the neutral element of ArityType.
+
+* This works if the join point is bound in the expression we are
+ taking the arityType of. But if it's bound further out, it makes
+ no sense to say that (say) the arityType of (j False) is ABot 0.
+ Bad things happen. So we keep track of the in-scope join-point Ids
+ in ae_join.
+
+This will make f, above, have arity 2. Then, we'll eta-expand it thus:
+
+ f x eta = (join j y = ... in case x of ...) eta
+
+and the Simplify will automatically push that application of eta into
+the join points.
+
+An alternative (roughly equivalent) idea would be to carry an
+environment mapping let-bound Ids to their ArityType.
+-}
+
{-
%************************************************************************
%* *
=====================================
testsuite/tests/simplCore/should_compile/T18328.hs
=====================================
@@ -0,0 +1,14 @@
+module T18328 where
+
+f :: Int -> [a] -> [a] -> [a]
+f x ys = let {-# NOINLINE j #-}
+ j y = case x of
+ 3 -> ((++) ys) . ((++) ys) . ((++) ys) . ((++) ys)
+ _ -> ((++) ys) . ((++) ys) . ((++) ys)
+
+ in
+ case x of
+ 1 -> j 2
+ 2 -> j 3
+ 3 -> j 4
+ _ -> ((++) ys)
=====================================
testsuite/tests/simplCore/should_compile/T18328.stderr
=====================================
@@ -0,0 +1,87 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 69, types: 61, coercions: 0, joins: 1/1}
+
+-- RHS size: {terms: 42, types: 28, coercions: 0, joins: 1/1}
+T18328.$wf [InlPrag=NOUSERINLINE[2]]
+ :: forall {a}. GHC.Prim.Int# -> [a] -> [a] -> [a]
+[GblId,
+ Arity=3,
+ Str=<S,U><S,U><L,1*U>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [182 0 0] 312 0}]
+T18328.$wf
+ = \ (@a) (ww :: GHC.Prim.Int#) (w :: [a]) (w1 :: [a]) ->
+ join {
+ $wj [InlPrag=NOINLINE, Dmd=<L,1*C1(U)>]
+ :: forall {p}. GHC.Prim.Void# -> [a]
+ [LclId[JoinId(2)], Arity=1, Str=<L,A>, Unf=OtherCon []]
+ $wj (@p) _ [Occ=Dead, OS=OneShot]
+ = case ww of {
+ __DEFAULT -> ++ @a w (++ @a w (++ @a w w1));
+ 3# -> ++ @a w (++ @a w (++ @a w (++ @a w w1)))
+ } } in
+ case ww of {
+ __DEFAULT -> ++ @a w w1;
+ 1# -> jump $wj @Integer GHC.Prim.void#;
+ 2# -> jump $wj @Integer GHC.Prim.void#;
+ 3# -> jump $wj @Integer GHC.Prim.void#
+ }
+
+-- RHS size: {terms: 11, types: 10, coercions: 0, joins: 0/0}
+f [InlPrag=NOUSERINLINE[2]] :: forall a. Int -> [a] -> [a] -> [a]
+[GblId,
+ Arity=3,
+ Str=<S(S),1*U(U)><S,U><L,1*U>,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a)
+ (w [Occ=Once!] :: Int)
+ (w1 [Occ=Once] :: [a])
+ (w2 [Occ=Once] :: [a]) ->
+ case w of { GHC.Types.I# ww1 [Occ=Once] ->
+ T18328.$wf @a ww1 w1 w2
+ }}]
+f = \ (@a) (w :: Int) (w1 :: [a]) (w2 :: [a]) ->
+ case w of { GHC.Types.I# ww1 -> T18328.$wf @a ww1 w1 w2 }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18328.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T18328.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18328.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T18328.$trModule3 = GHC.Types.TrNameS T18328.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18328.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T18328.$trModule2 = "T18328"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18328.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T18328.$trModule1 = GHC.Types.TrNameS T18328.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18328.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+T18328.$trModule
+ = GHC.Types.Module T18328.$trModule3 T18328.$trModule1
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -328,3 +328,4 @@ test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], com
# Cast WW
test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
+test('T18328', [ only_ways(['optasm']), grep_errmsg(r'Arity=') ], compile, ['-ddump-simpl -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bccde026a5476c321fc9d025de09e25b91adaa5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bccde026a5476c321fc9d025de09e25b91adaa5
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200618/a3ac7545/attachment-0001.html>
More information about the ghc-commits
mailing list