[Git][ghc/ghc][wip/marge_bot_batch_merge_job] Add a missing trimArityType
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Aug 31 04:53:26 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
47479bde by Simon Peyton Jones at 2022-08-31T00:53:11-04:00
Add a missing trimArityType
This buglet was exposed by #22114, a consequence of my earlier
refactoring of arity for join points.
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- + testsuite/tests/simplCore/should_compile/T22114.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -873,24 +873,49 @@ exprEtaExpandArity opts e
* *
********************************************************************* -}
-findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr -> Arity -> SafeArityType
+findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr
+ -> (Bool, SafeArityType)
-- This implements the fixpoint loop for arity analysis
-- See Note [Arity analysis]
--- If findRhsArity e = (n, is_bot) then
--- (a) any application of e to <n arguments will not do much work,
--- so it is safe to expand e ==> (\x1..xn. e x1 .. xn)
--- (b) if is_bot=True, then e applied to n args is guaranteed bottom
--
--- Returns an ArityType that is guaranteed trimmed to typeArity of 'bndr'
+-- The Bool is True if the returned arity is greater than (exprArity rhs)
+-- so the caller should do eta-expansion
+-- That Bool is never True for join points, which are never eta-expanded
+--
+-- Returns an SafeArityType that is guaranteed trimmed to typeArity of 'bndr'
-- See Note [Arity trimming]
-findRhsArity opts is_rec bndr rhs old_arity
- = case is_rec of
- Recursive -> go 0 botArityType
- NonRecursive -> step init_env
+
+findRhsArity opts is_rec bndr rhs
+ | isJoinId bndr
+ = (False, join_arity_type)
+ -- False: see Note [Do not eta-expand join points]
+ -- But do return the correct arity and bottom-ness, because
+ -- these are used to set the bndr's IdInfo (#15517)
+ -- Note [Invariants on join points] invariant 2b, in GHC.Core
+
+ | otherwise
+ = (arity_increased, non_join_arity_type)
+ -- arity_increased: eta-expand if we'll get more lambdas
+ -- to the top of the RHS
where
+ old_arity = exprArity rhs
+
init_env :: ArityEnv
init_env = findRhsArityEnv opts (isJoinId bndr)
+ -- Non-join-points only
+ non_join_arity_type = case is_rec of
+ Recursive -> go 0 botArityType
+ NonRecursive -> step init_env
+ arity_increased = arityTypeArity non_join_arity_type > old_arity
+
+ -- Join-points only
+ -- See Note [Arity for non-recursive join bindings]
+ -- and Note [Arity for recursive join bindings]
+ join_arity_type = case is_rec of
+ Recursive -> go 0 botArityType
+ NonRecursive -> trimArityType ty_arity (cheapArityType rhs)
+
ty_arity = typeArity (idType bndr)
id_one_shots = idDemandOneShots bndr
@@ -1076,6 +1101,117 @@ But /only/ for called-once demands. Suppose we had
Now we don't want to eta-expand f1 to have 3 args; only two.
Nor, in the case of f2, do we want to push that error call under
a lambda. Hence the takeWhile in combineWithDemandDoneShots.
+
+Note [Do not eta-expand join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Similarly to CPR (see Note [Don't w/w join points for CPR] in
+GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's
+eta-expansion, and eta-expanding a join point is fraught with issues like how to
+deal with a cast:
+
+ let join $j1 :: IO ()
+ $j1 = ...
+ $j2 :: Int -> IO ()
+ $j2 n = if n > 0 then $j1
+ else ...
+
+ =>
+
+ let join $j1 :: IO ()
+ $j1 = (\eta -> ...)
+ `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
+ ~ IO ()
+ $j2 :: Int -> IO ()
+ $j2 n = (\eta -> if n > 0 then $j1
+ else ...)
+ `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
+ ~ IO ()
+
+The cast here can't be pushed inside the lambda (since it's not casting to a
+function type), so the lambda has to stay, but it can't because it contains a
+reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather
+than try and detect this situation (and whatever other situations crop up!), we
+don't bother; again, any surrounding eta-expansion will improve these join
+points anyway, since an outer cast can *always* be pushed inside. By the time
+CorePrep comes around, the code is very likely to look more like this:
+
+ let join $j1 :: State# RealWorld -> (# State# RealWorld, ())
+ $j1 = (...) eta
+ $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())
+ $j2 = if n > 0 then $j1
+ else (...) eta
+
+Note [Arity for recursive join bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ f x = joinrec j 0 = \ a b c -> (a,x,b)
+ j n = j (n-1)
+ in j 20
+
+Obviously `f` should get arity 4. But it's a bit tricky:
+
+1. Remember, we don't eta-expand join points; see
+ Note [Do not eta-expand join points].
+
+2. But even though we aren't going to eta-expand it, we still want `j` to get
+ idArity=4, via the findRhsArity fixpoint. Then when we are doing findRhsArity
+ for `f`, we'll call arityType on f's RHS:
+ - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType
+ for `j` (See Note [arityType for non-recursive let-bindings]
+ in GHC.Core.Opt.Arity)b
+ - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3
+ result.
+
+3. All this, even though j's /join-arity/ (stored in the JoinId) is 1.
+ This is is the Main Reason that we want the idArity to sometimes be
+ larger than the join-arity c.f. Note [Invariants on join points] item 2b
+ in GHC.Core.
+
+4. Be very careful of things like this (#21755):
+ g x = let j 0 = \y -> (x,y)
+ j n = expensive n `seq` j (n-1)
+ in j x
+ Here we do /not/ want eta-expand `g`, lest we duplicate all those
+ (expensive n) calls.
+
+ But it's fine: the findRhsArity fixpoint calculation will compute arity-1
+ for `j` (not arity 2); and that's just what we want. But we do need that
+ fixpoint.
+
+ Historical note: an earlier version of GHC did a hack in which we gave
+ join points an ArityType of ABot, but that did not work with this #21755
+ case.
+
+5. arityType does not usually expect to encounter free join points;
+ see GHC.Core.Opt.Arity Note [No free join points in arityType].
+ But consider
+ f x = join j1 y = .... in
+ joinrec j2 z = ...j1 y... in
+ j2 v
+
+ When doing findRhsArity on `j2` we'll encounter the free `j1`.
+ But that is fine, because we aren't going to eta-expand `j2`;
+ we just want to know its arity. So we have a flag am_no_eta,
+ switched on when doing findRhsArity on a join point RHS. If
+ the flag is on, we allow free join points, but not otherwise.
+
+
+Note [Arity for non-recursive join bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Arity for recursive join bindings] deals with recursive join
+bindings. But what about /non-recursive/ones? If we just call
+findRhsArity, it will call arityType. And that can be expensive when
+we have deeply nested join points:
+ join j1 x1 = join j2 x2 = join j3 x3 = blah3
+ in blah2
+ in blah1
+(e.g. test T18698b).
+
+So we call cheapArityType instead. It's good enough for practical
+purposes.
+
+(Side note: maybe we should use cheapArity for the RHS of let bindings
+in the main arityType function.)
-}
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -102,6 +102,14 @@ bindContextLevel :: BindContext -> TopLevelFlag
bindContextLevel (BC_Let top_lvl _) = top_lvl
bindContextLevel (BC_Join {}) = NotTopLevel
+bindContextRec :: BindContext -> RecFlag
+bindContextRec (BC_Let _ rec_flag) = rec_flag
+bindContextRec (BC_Join rec_flag _) = rec_flag
+
+isJoinBC :: BindContext -> Bool
+isJoinBC (BC_Let {}) = False
+isJoinBC (BC_Join {}) = True
+
{- *********************************************************************
* *
@@ -1776,39 +1784,26 @@ Wrinkles
tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr
-> SimplM (ArityType, OutExpr)
-- See Note [Eta-expanding at let bindings]
--- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then
--- (a) rhs' has manifest arity n
--- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom
-tryEtaExpandRhs env (BC_Join is_rec _) bndr rhs
- = assertPpr (isJoinId bndr) (ppr bndr) $
- return (arity_type, rhs)
- -- Note [Do not eta-expand join points]
- -- But do return the correct arity and bottom-ness, because
- -- these are used to set the bndr's IdInfo (#15517)
- -- Note [Invariants on join points] invariant 2b, in GHC.Core
- where
- -- See Note [Arity for non-recursive join bindings]
- -- and Note [Arity for recursive join bindings]
- arity_type = case is_rec of
- NonRecursive -> cheapArityType rhs
- Recursive -> findRhsArity (seArityOpts env) Recursive
- bndr rhs (exprArity rhs)
-
-tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs
- | seEtaExpand env -- Provided eta-expansion is on
- , new_arity > old_arity -- And the current manifest arity isn't enough
+tryEtaExpandRhs env bind_cxt bndr rhs
+ | do_eta_expand -- If the current manifest arity isn't enough
+ -- (never true for join points)
+ , seEtaExpand env -- and eta-expansion is on
, wantEtaExpansion rhs
- = do { tick (EtaExpansion bndr)
+ = -- Do eta-expansion.
+ assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $
+ -- assert: this never happens for join points; see GHC.Core.Opt.Arity
+ -- Note [Do not eta-expand join points]
+ do { tick (EtaExpansion bndr)
; return (arity_type, etaExpandAT in_scope arity_type rhs) }
| otherwise
= return (arity_type, rhs)
+
where
in_scope = getInScope env
- old_arity = exprArity rhs
arity_opts = seArityOpts env
- arity_type = findRhsArity arity_opts is_rec bndr rhs old_arity
- new_arity = arityTypeArity arity_type
+ is_rec = bindContextRec bind_cxt
+ (do_eta_expand, arity_type) = findRhsArity arity_opts is_rec bndr rhs
wantEtaExpansion :: CoreExpr -> Bool
-- Mostly True; but False of PAPs which will immediately eta-reduce again
@@ -1894,117 +1889,6 @@ But note that this won't eta-expand, say
Does it matter not eta-expanding such functions? I'm not sure. Perhaps
strictness analysis will have less to bite on?
-Note [Do not eta-expand join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Similarly to CPR (see Note [Don't w/w join points for CPR] in
-GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's
-eta-expansion, and eta-expanding a join point is fraught with issues like how to
-deal with a cast:
-
- let join $j1 :: IO ()
- $j1 = ...
- $j2 :: Int -> IO ()
- $j2 n = if n > 0 then $j1
- else ...
-
- =>
-
- let join $j1 :: IO ()
- $j1 = (\eta -> ...)
- `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
- ~ IO ()
- $j2 :: Int -> IO ()
- $j2 n = (\eta -> if n > 0 then $j1
- else ...)
- `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
- ~ IO ()
-
-The cast here can't be pushed inside the lambda (since it's not casting to a
-function type), so the lambda has to stay, but it can't because it contains a
-reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather
-than try and detect this situation (and whatever other situations crop up!), we
-don't bother; again, any surrounding eta-expansion will improve these join
-points anyway, since an outer cast can *always* be pushed inside. By the time
-CorePrep comes around, the code is very likely to look more like this:
-
- let join $j1 :: State# RealWorld -> (# State# RealWorld, ())
- $j1 = (...) eta
- $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())
- $j2 = if n > 0 then $j1
- else (...) eta
-
-Note [Arity for recursive join bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- f x = joinrec j 0 = \ a b c -> (a,x,b)
- j n = j (n-1)
- in j 20
-
-Obviously `f` should get arity 4. But it's a bit tricky:
-
-1. Remember, we don't eta-expand join points; see
- Note [Do not eta-expand join points].
-
-2. But even though we aren't going to eta-expand it, we still want `j` to get
- idArity=4, via the findRhsArity fixpoint. Then when we are doing findRhsArity
- for `f`, we'll call arityType on f's RHS:
- - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType
- for `j` (See Note [arityType for non-recursive let-bindings]
- in GHC.Core.Opt.Arity)b
- - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3
- result.
-
-3. All this, even though j's /join-arity/ (stored in the JoinId) is 1.
- This is is the Main Reason that we want the idArity to sometimes be
- larger than the join-arity c.f. Note [Invariants on join points] item 2b
- in GHC.Core.
-
-4. Be very careful of things like this (#21755):
- g x = let j 0 = \y -> (x,y)
- j n = expensive n `seq` j (n-1)
- in j x
- Here we do /not/ want eta-expand `g`, lest we duplicate all those
- (expensive n) calls.
-
- But it's fine: the findRhsArity fixpoint calculation will compute arity-1
- for `j` (not arity 2); and that's just what we want. But we do need that
- fixpoint.
-
- Historical note: an earlier version of GHC did a hack in which we gave
- join points an ArityType of ABot, but that did not work with this #21755
- case.
-
-5. arityType does not usually expect to encounter free join points;
- see GHC.Core.Opt.Arity Note [No free join points in arityType].
- But consider
- f x = join j1 y = .... in
- joinrec j2 z = ...j1 y... in
- j2 v
-
- When doing findRhsArity on `j2` we'll encounter the free `j1`.
- But that is fine, because we aren't going to eta-expand `j2`;
- we just want to know its arity. So we have a flag am_no_eta,
- switched on when doing findRhsArity on a join point RHS. If
- the flag is on, we allow free join points, but not otherwise.
-
-
-Note [Arity for non-recursive join bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Note [Arity for recursive join bindings] deals with recursive join
-bindings. But what about /non-recursive/ones? If we just call
-findRhsArity, it will call arityType. And that can be expensive when
-we have deeply nested join points:
- join j1 x1 = join j2 x2 = join j3 x3 = blah3
- in blah2
- in blah1
-(e.g. test T18698b).
-
-So we call cheapArityType instead. It's good enough for practical
-purposes.
-
-(Side note: maybe we should use cheapArity for the RHS of let bindings
-in the main arityType function.)
-
************************************************************************
* *
=====================================
testsuite/tests/simplCore/should_compile/T22114.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T22114 where
+
+import Data.Kind (Type)
+
+value :: [Int] -> () -> Maybe Bool
+value = valu
+ where valu [0] = valuN
+ valu _ = \_ -> Nothing
+
+type family T :: Type where
+ T = () -> Maybe Bool
+
+valuN :: T
+valuN = valuN
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -428,3 +428,4 @@ test('T21948', [grep_errmsg(r'^ Arity=5') ], compile, ['-O -ddump-simpl'])
test('T21763', only_ways(['optasm']), compile, ['-O2 -ddump-rules'])
test('T21763a', only_ways(['optasm']), compile, ['-O2 -ddump-rules'])
test('T22028', normal, compile, ['-O -ddump-rule-firings'])
+test('T22114', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47479bde7a2eb4150e51c3034cd2323c58d018ca
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47479bde7a2eb4150e51c3034cd2323c58d018ca
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/20220831/3813207f/attachment-0001.html>
More information about the ghc-commits
mailing list