[Git][ghc/ghc][wip/T21694a] Respond to SG
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Aug 23 16:08:01 UTC 2022
Simon Peyton Jones pushed to branch wip/T21694a at Glasgow Haskell Compiler / GHC
Commits:
5175f211 by Simon Peyton Jones at 2022-08-23T17:09:20+01:00
Respond to SG
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -1243,28 +1243,28 @@ dictionary-typed expression, but that's more work.
---------------------------
data ArityEnv
- = AE { am_opts :: !ArityOpts
- , am_no_eta :: !Bool
- , am_sigs :: !(IdEnv SafeArityType) }
+ = AE { am_opts :: !ArityOpts
+ , am_free_joins :: !Bool -- True <=> free join points allowed
+ , am_sigs :: !(IdEnv SafeArityType) }
-- ^ See Note [Arity analysis] for details about fixed-point iteration.
-- am_sigs: NB `SafeArityType` so we can use this in myIsCheapApp
- -- am_no_eta: see Note [Arity for recursive join bindings]
+ -- am_free_joins: see Note [Arity for recursive join bindings]
-- point 5, in GHC.Core.Opt.Simplify.Utils
instance Outputable ArityEnv where
- ppr (AE { am_sigs = sigs, am_no_eta = no_eta })
- = text "AE" <+> braces (sep [ text "no-eta" <+> ppr no_eta
- , text "sigs" <+> ppr sigs ])
+ ppr (AE { am_sigs = sigs, am_free_joins = free_joins })
+ = text "AE" <+> braces (sep [ text "free joins:" <+> ppr free_joins
+ , text "sigs:" <+> ppr sigs ])
-- | The @ArityEnv@ used by 'findRhsArity'.
findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv
-findRhsArityEnv opts no_eta
- = AE { am_opts = opts
- , am_no_eta = no_eta
- , am_sigs = emptyVarEnv }
+findRhsArityEnv opts free_joins
+ = AE { am_opts = opts
+ , am_free_joins = free_joins
+ , am_sigs = emptyVarEnv }
-isNoEtaEnv :: ArityEnv -> Bool
-isNoEtaEnv (AE { am_no_eta = no_eta }) = no_eta
+freeJoinsOK :: ArityEnv -> Bool
+freeJoinsOK (AE { am_free_joins = free_joins }) = free_joins
-- First some internal functions in snake_case for deleting in certain VarEnvs
-- of the ArityType. Don't call these; call delInScope* instead!
@@ -1348,11 +1348,14 @@ arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType
-- Precondition: all the free join points of the expression
-- are bound by the ArityEnv
-- See Note [No free join points in arityType]
+--
+-- Returns ArityType, not SafeArityType. The caller must do
+-- trimArityType if necessary.
arityType env (Var v)
| Just at <- lookupSigEnv env v -- Local binding
= at
| otherwise
- = assertPpr (isNoEtaEnv env || not (isJoinId v)) (ppr v) $
+ = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $
-- All join-point should be in the ae_sigs
-- See Note [No free join points in arityType]
idArityType v
@@ -1403,14 +1406,14 @@ arityType env (Case scrut bndr _ alts)
alts_type = foldr1 (andArityType env) (map arity_type_alt alts)
arityType env (Let (NonRec b rhs) e)
- = -- See Note [arityType for let-bindings]
+ = -- See Note [arityType for non-recursive let-bindings]
floatIn rhs_cost (arityType env' e)
where
rhs_cost = exprCost env rhs (Just (idType b))
env' = extendSigEnv env b (safeArityType (arityType env rhs))
arityType env (Let (Rec prs) e)
- = -- See Note [arityType for let-bindings]
+ = -- See Note [arityType for recursive let-bindings]
floatIn (allCosts bind_cost prs) (arityType env' e)
where
bind_cost (b,e) = exprCost env' e (Just (idType b))
@@ -1418,10 +1421,7 @@ arityType env (Let (Rec prs) e)
extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv
extend_rec env (b,_) = extendSigEnv env b $
idArityType b
- -- We can't call arityType on the RHS, because it might mention
- -- join points bound in this very letrec, and we don't want to
- -- do a fixpoint calculation here. So we make do with the
- -- idArityType. See Note [arityType for let-bindings]
+ -- See Note [arityType for recursive let-bindings]
arityType env (Tick t e)
| not (tickishIsCode t) = arityType env e
@@ -1452,9 +1452,15 @@ cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType
-- A fast and cheap version of arityType.
-- Returns an ArityType with IsCheap everywhere
-- c.f. GHC.Core.Utils.exprIsDeadEnd
+-- Does not expect to encounter a free join-point Id
+-- See Note [No free join points in arityType]
+--
+-- Returns ArityType, not SafeArityType. The caller must do
+-- trimArityType if necessary.
cheapArityType e = go e
where
- go (Var v) = idArityType v
+ go (Var v) = assertPpr( not (isJoinId v) ) (ppr v) $
+ idArityType v
go (Cast e _) = go e
go (Lam x e) | isId x = arityLam x (go e)
| otherwise = go e
@@ -1473,8 +1479,9 @@ cheapArityType e = go e
-- See Note [exprArity for applications]
-- NB: coercions count as a value argument
arity_app _ at@(AT [] _) = at
- arity_app arg (AT (_:lams) div)
- | isDeadEndDiv div = AT lams div
+ arity_app arg at@(AT ((cost,_):lams) div)
+ | assertPpr (cost == IsCheap) (ppr at $$ ppr arg) $
+ isDeadEndDiv div = AT lams div
| exprIsTrivial arg = AT lams topDiv
| otherwise = topArityType
@@ -1503,7 +1510,9 @@ exprArity e = go e
exprIsDeadEnd :: CoreExpr -> Bool
-- See Note [Bottoming expressions]
-- This function is, in effect, just a specialised (and hence cheap)
--- version of cheapArityType
+-- version of cheapArityType:
+-- exprIsDeadEnd e = case cheapArityType e of
+-- AT lams div -> null lams && isDeadEndDiv div
-- See also exprBotStrictness_maybe, which uses cheapArityType
exprIsDeadEnd e
= go 0 e
@@ -1600,8 +1609,8 @@ Wrinkles
so that OccurAnal has seen it and allowed join points bound outside.
See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration.
-Note [arityType for let-bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [arityType for non-recursive let-bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For non-recursive let-bindings, we just get the arityType of the RHS,
and extend the environment. That works nicely for things like this
(#18793):
@@ -1632,11 +1641,24 @@ arity of f? If we inlined the join point, we'd definitely say "arity
lambda. It's important that we extend the envt with j's ArityType, so
that we can use that information in the A/C branch of the case.
-For /recursive/ bindings it's more difficult, to call arityType,
+Note [arityType for recursive let-bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For /recursive/ bindings it's more difficult, to call arityType
+(as we do in Note [arityType for non-recursive let-bindings])
because we don't have an ArityType to put in the envt for the
-recursively bound Ids. So for non-join-point bindings we satisfy
-ourselves with whizzing up up an ArityType from the idArity of the
-function, via idArityType.
+recursively bound Ids. So for we satisfy ourselves with whizzing up
+up an ArityType from the idArity of the function, via idArityType.
+
+That is nearly equivalent to deleting the binder from the envt, at
+which point we'll call idArityType at the occurrences. But doing it
+here means
+
+ (a) we only call idArityType once, no matter how many
+ occurrences, and
+
+ (b) we can check (in the arityType (Var v) case) that
+ we don't mention free join-point Ids. See
+ Note [No free join points in arityType].
But see Note [Arity for recursive join bindings] in
GHC.Core.Opt.Simplify.Utils for dark corners.
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1989,11 +1989,13 @@ Obviously `f` should get arity 4. But it's a bit tricky:
Note [Arity for non-recursive join bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-So much for recursive join bindings (see previous Note). 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
+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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5175f2111987eec1cb0ca5a04ab71494b4eefec1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5175f2111987eec1cb0ca5a04ab71494b4eefec1
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/20220823/1874789a/attachment-0001.html>
More information about the ghc-commits
mailing list