[Git][ghc/ghc][wip/T21694] 2 commits: Revert "Further wibbles"
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Thu Aug 18 13:42:22 UTC 2022
Andreas Klebinger pushed to branch wip/T21694 at Glasgow Haskell Compiler / GHC
Commits:
cda970b7 by Andreas Klebinger at 2022-08-18T15:40:45+02:00
Revert "Further wibbles"
This reverts commit 3993bbb202499fdef3292f9e34c929d96db4529c.
- - - - -
85048c98 by Andreas Klebinger at 2022-08-18T15:40:53+02:00
Revert "Try giving join points proper ArityInfo"
This reverts commit 734bb04f1863b1c200108fd608bb80189b0c4869.
- - - - -
5 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -746,18 +746,18 @@ Join points must follow these invariants:
the binder. Reason: if we want to push a continuation into
the RHS we must push it into the unfolding as well.
- 2b. The Arity (in the IdInfo) of a join point varies independently of the
- join-arity. For example, we could have
- j x = case x of { T -> \y.y; F -> \y.3 }
- Its join-arity is 1, but its idArity is 2; and we do not eta-expand
- join points: see Note [Do not eta-expand join points] in
- GHC.Core.Opt.Simplify.Utils.
-
- Allowing the idArity to be bigger than the join-arity is
- important in arityType; see GHC.Core.Opt.Arity
- Note [Arity type for recursive join bindings]
-
- Historical note: see #17294.
+ 2b. The Arity (in the IdInfo) of a join point is the number of value
+ binders in the top n lambdas, where n is the join arity.
+
+ So arity <= join arity; the former counts only value binders
+ while the latter counts all binders.
+ e.g. Suppose $j has join arity 1
+ let j = \x y. e in case x of { A -> j 1; B -> j 2 }
+ Then its ordinary arity is also 1, not 2.
+
+ The arity of a join point isn't very important; but short of setting
+ it to zero, it is helpful to have an invariant. E.g. #17294.
+ See also Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils.
3. If the binding is recursive, then all other bindings in the recursive group
must also be join points.
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Core.Opt.Arity
, tryEtaReduce
-- ** ArityType
- , ArityType, mkBotArityType
+ , ArityType, mkBotArityType, mkManifestArityType
, arityTypeArity, idArityType, getBotArity
-- ** typeArity and the state hack
@@ -813,6 +813,14 @@ mkBotArityType oss = AT [(IsCheap,os) | os <- oss] botDiv
botArityType :: ArityType
botArityType = mkBotArityType []
+mkManifestArityType :: [Var] -> CoreExpr -> ArityType
+mkManifestArityType bndrs body
+ = AT oss div
+ where
+ oss = [(IsCheap, idOneShotInfo bndr) | bndr <- bndrs, isId bndr]
+ div | exprIsDeadEnd body = botDiv
+ | otherwise = topDiv
+
topArityType :: ArityType
topArityType = AT [] topDiv
@@ -848,7 +856,7 @@ trimArityType :: Arity -> ArityType -> ArityType
-- they end in 'ABot'. See Note [Arity trimming]
trimArityType max_arity at@(AT lams _)
| lams `lengthAtMost` max_arity = at
- | otherwise = AT (take max_arity lams) topDiv
+ | otherwise = AT (take max_arity lams) topDiv
data ArityOpts = ArityOpts
{ ao_ped_bot :: !Bool -- See Note [Dealing with bottom]
@@ -867,7 +875,7 @@ exprEtaExpandArity opts e
| otherwise
= Just arity_type
where
- arity_type = safeArityType (arityType (findRhsArityEnv opts False) e)
+ arity_type = safeArityType (arityType (findRhsArityEnv opts) e)
getBotArity :: ArityType -> Maybe Arity
-- Arity of a divergent function
@@ -898,7 +906,7 @@ findRhsArity opts is_rec bndr rhs old_arity
NonRecursive -> step init_env
where
init_env :: ArityEnv
- init_env = findRhsArityEnv opts (isJoinId bndr)
+ init_env = findRhsArityEnv opts
ty_arity = typeArity (idType bndr)
id_one_shots = idDemandOneShots bndr
@@ -943,9 +951,8 @@ combineWithDemandOneShots at@(AT lams div) oss
where
zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo]
zip_lams lams [] = lams
- zip_lams [] oss | isDeadEndDiv div = []
- | otherwise = [ (IsExpensive,OneShotLam)
- | _ <- takeWhile isOneShotInfo oss]
+ zip_lams [] oss = [ (IsExpensive,OneShotLam)
+ | _ <- takeWhile isOneShotInfo oss]
zip_lams ((ch,os1):lams) (os2:oss)
= (ch, os1 `bestOneShot` os2) : zip_lams lams oss
@@ -1270,14 +1277,16 @@ data AnalysisMode
= BotStrictness
-- ^ Used during 'exprBotStrictness_maybe'.
- | FindRhsArity { am_opts :: !ArityOpts
- , am_no_eta :: !Bool
- , am_sigs :: !(IdEnv SafeArityType) }
+ | EtaExpandArity { am_opts :: !ArityOpts }
+ -- ^ Used for finding an expression's eta-expanding arity quickly,
+ -- without fixed-point iteration ('exprEtaExpandArity').
+
+ | FindRhsArity { am_opts :: !ArityOpts
+ , am_sigs :: !(IdEnv SafeArityType) }
-- ^ Used for regular, fixed-point arity analysis ('findRhsArity').
-- 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 type for recursive join bindings]
- -- point 5
+ -- am_dicts_cheap: see Note [Eta expanding through dictionaries]
+ -- am_sigs: note `SafeArityType` so we can use this in myIsCheapApp
data ArityEnv
= AE
@@ -1285,36 +1294,34 @@ data ArityEnv
-- ^ The analysis mode. See 'AnalysisMode'.
}
-instance Outputable ArityEnv where
- ppr (AE mode) = ppr mode
-
-instance Outputable AnalysisMode where
- ppr BotStrictness = text "BotStrictness"
- ppr (FindRhsArity { am_sigs = sigs }) = text "FindRhsArity" <+> ppr sigs
-
-- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms
-- and no application is ever considered cheap.
botStrictnessArityEnv :: ArityEnv
botStrictnessArityEnv = AE { ae_mode = BotStrictness }
+{-
+-- | The @ArityEnv@ used by 'exprEtaExpandArity'.
+etaExpandArityEnv :: ArityOpts -> ArityEnv
+etaExpandArityEnv opts
+ = AE { ae_mode = EtaExpandArity { am_opts = opts } }
+-}
+
-- | The @ArityEnv@ used by 'findRhsArity'.
-findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv
-findRhsArityEnv opts no_eta
+findRhsArityEnv :: ArityOpts -> ArityEnv
+findRhsArityEnv opts
= AE { ae_mode = FindRhsArity { am_opts = opts
- , am_no_eta = no_eta
, am_sigs = emptyVarEnv } }
-isNoEtaEnv :: ArityEnv -> Bool
-isNoEtaEnv ae = case ae_mode ae of
- FindRhsArity { am_no_eta = no_eta } -> no_eta
- BotStrictness -> True
+isFindRhsArity :: ArityEnv -> Bool
+isFindRhsArity (AE { ae_mode = FindRhsArity {} }) = True
+isFindRhsArity _ = False
-- First some internal functions in snake_case for deleting in certain VarEnvs
-- of the ArityType. Don't call these; call delInScope* instead!
modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv
-modifySigEnv f env at AE { ae_mode = am at FindRhsArity{am_sigs = sigs} }
- = env { ae_mode = am { am_sigs = f sigs } }
+modifySigEnv f env at AE { ae_mode = am at FindRhsArity{am_sigs = sigs} } =
+ env { ae_mode = am { am_sigs = f sigs } }
modifySigEnv _ env = env
{-# INLINE modifySigEnv #-}
@@ -1342,6 +1349,7 @@ delInScopeList env ids = del_sig_env_list ids env
lookupSigEnv :: ArityEnv -> Id -> Maybe SafeArityType
lookupSigEnv AE{ ae_mode = mode } id = case mode of
BotStrictness -> Nothing
+ EtaExpandArity{} -> Nothing
FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id
-- | Whether the analysis should be pedantic about bottoms.
@@ -1349,6 +1357,7 @@ lookupSigEnv AE{ ae_mode = mode } id = case mode of
pedanticBottoms :: ArityEnv -> Bool
pedanticBottoms AE{ ae_mode = mode } = case mode of
BotStrictness -> True
+ EtaExpandArity{ am_opts = ArityOpts{ ao_ped_bot = ped_bot } } -> ped_bot
FindRhsArity{ am_opts = ArityOpts{ ao_ped_bot = ped_bot } } -> ped_bot
exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost
@@ -1375,6 +1384,7 @@ myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of
#if __GLASGOW_HASKELL__ <= 900
BotStrictness -> panic "impossible"
#endif
+ EtaExpandArity{} -> exprIsCheap e
FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) e
-- | A version of 'isCheapApp' that considers results from arity analysis.
@@ -1406,7 +1416,7 @@ arityType env (Var v)
| Just at <- lookupSigEnv env v -- Local binding
= at
| otherwise
- = assertPpr (isNoEtaEnv env || not (isJoinId v)) (ppr v) $
+ = assertPpr (not (isFindRhsArity env && isJoinId v)) (ppr v) $
-- All join-point should be in the ae_sigs
-- See Note [No free join points in arityType]
idArityType v
@@ -1463,6 +1473,22 @@ arityType env (Let (NonRec b rhs) e)
rhs_cost = exprCost env rhs (Just (idType b))
env' = extendSigEnv env b (safeArityType (arityType env rhs))
+arityType env (Let (Rec pairs) body)
+ | ((j,_):_) <- pairs
+ , isJoinId j
+ = -- See Note [arityType for join bindings]
+ foldr (andArityType env . do_one) (arityType rec_env body) pairs
+ where
+ rec_env = foldl add_bot env pairs
+ add_bot env (j,_) = extendSigEnv env j botArityType
+
+ do_one :: (JoinId, CoreExpr) -> ArityType
+ do_one (j,rhs)
+ | Just arity <- isJoinId_maybe j
+ = arityType rec_env $ snd $ collectNBinders arity rhs
+ | otherwise
+ = pprPanic "arityType:joinrec" (ppr pairs)
+
arityType env (Let (Rec prs) e)
= -- See Note [arityType for let-bindings]
floatIn (allCosts bind_cost prs) (arityType env' e)
@@ -1470,12 +1496,14 @@ arityType env (Let (Rec prs) e)
bind_cost (b,e) = exprCost env' e (Just (idType b))
env' = foldl extend_rec env prs
extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv
- extend_rec env (b,_) = extendSigEnv env b $
- idArityType b
+ extend_rec env (b,e) = extendSigEnv env b $
+ mkManifestArityType bndrs body
+ where
+ (bndrs, body) = collectBinders e
-- 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]
+ -- manifest arity
arityType env (Tick t e)
| not (tickishIsCode t) = arityType env e
@@ -1503,28 +1531,20 @@ propagate it to the usage site as usual.
But how can we get (EX1)? It doesn't make much sense, because $j can't
be a join point under the \x anyway. So we make it a precondition of
arityType that the argument has no free join-point Ids. (This is checked
-with an assert in the Var case of arityType.)
-
-Wrinkles
-
-* We /do/ allow free join point when doing findRhsArity for join-point
- right-hand sides. See Note [Arity type for recursive join bindings]
- point (5).
-
-* The invariant (no free join point in arityType) risks being
- invalidated by one very narrow special case: runRW#
+with an assesrt in the Var case of arityType.)
+BUT the invariant risks being invalidated by one very narrow special case: runRW#
join $j y = blah
runRW# (\s. case x of True -> \y. e
False -> $j x)
- We have special magic in OccurAnal, and Simplify to allow continuations to
- move into the body of a runRW# call.
+We have special magic in OccurAnal, and Simplify to allow continuations to
+move into the body of a runRW# call.
- So we are careful never to attempt to eta-expand the (\s.blah) in the
- argument to runRW#, at least not when there is a literal lambda there,
- 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.
+So we are careful never to attempt to eta-expand the (\s.blah) in the
+argument to runRW#, at least not when there is a literal lambda there,
+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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1555,16 +1575,18 @@ All this is particularly important for join points. Consider this (#18328)
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. 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.
+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,
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.
+ourselves with mkManifestArityType. Typically we'll have eta-expanded
+the binding (based on an earlier fixpoint calculation in
+findRhsArity), so the manifest arity is good.
-But see Note [Arity type for recursive join bindings] for dark corners.
+But for /recursive join points/ things are not so good.
+See Note [Arity type for recursive join bindings]
See Note [Arity type for recursive join bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1573,59 +1595,54 @@ Consider
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 GHC.Core.Opt.Simplify.Utils
- 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 findRhsArity, so that in arityType,
- - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType
- for `j` (Note [arityType for let-bindings])
- - 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 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.
+Obviously `f` should get arity 4. But the manifest arity of `j`
+is 1. Remember, we don't eta-expand join points; see
+GHC.Core.Opt.Simplify.Utils Note [Do not eta-expand join points].
+And the ArityInfo on `j` will be just 1 too; see GHC.Core
+Note [Invariants on join points], item (2b). So using
+Note [ArityType for let-bindings] won't work well.
+
+We could do a fixpoint iteration, but that's a heavy hammer
+to use in arityType. So we take advantage of it being a join
+point:
+
+* Extend the ArityEnv to bind each of the recursive binders
+ (all join points) to `botArityType`. This means that any
+ jump to the join point will return botArityType, which is
+ unit for `andArityType`:
+ botAritType `andArityType` at = at
+ So it's almost as if those "jump" branches didn't exist.
+
+* In this extended env, find the ArityType of each of the RHS, after
+ stripping off the join-point binders.
+
+* Use andArityType to combine all these RHS ArityTypes.
+
+* Find the ArityType of the body, also in this strange extended
+ environment
+
+* And combine that into the result with andArityType.
+
+In our example, the jump (j 20) will yield Bot, as will the jump
+(j (n-1)). We'll 'and' those the ArityType of (\abc. blah). Good!
+
+In effect we are treating the RHSs as alternative bodies (like
+in a case), and ignoring all jumps. In this way we don't need
+to take a fixpoint. Tricky!
+
+NB: we treat /non-recursive/ join points in the same way, but
+actually it works fine to treat them uniformly with normal
+let-bindings, and that takes less code.
-}
idArityType :: Id -> ArityType
idArityType v
| strict_sig <- idDmdSig v
+ , not $ isNopSig strict_sig
, (ds, div) <- splitDmdSig strict_sig
- , isDeadEndDiv div
, let arity = length ds
+ -- Every strictness signature admits an arity signature!
= AT (take arity one_shots) div
-
| otherwise
= AT (take (idArity v) one_shots) topDiv
where
@@ -1876,7 +1893,7 @@ nested newtypes. This is expressed by the EtaInfo type:
Note [Check for reflexive casts in eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It turns out that the casts created by the above mechanism are often Refl.
+It turns out that the casts created by teh above mechanism are often Refl.
When casts are very deeply nested (as happens in #18223), the repetition
of types can make the overall term very large. So there is a big
payoff in cancelling out casts aggressively wherever possible.
=====================================
compiler/GHC/Core/Opt/FloatOut.hs
=====================================
@@ -15,13 +15,12 @@ import GHC.Prelude
import GHC.Core
import GHC.Core.Utils
import GHC.Core.Make
--- import GHC.Core.Opt.Arity ( exprArity, etaExpand )
+import GHC.Core.Opt.Arity ( exprArity, etaExpand )
import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
import GHC.Driver.Flags ( DumpFlag (..) )
import GHC.Utils.Logger
-import GHC.Types.Id ( Id, idType,
--- idArity, isDeadEndId,
+import GHC.Types.Id ( Id, idArity, idType, isDeadEndId,
isJoinId, isJoinId_maybe )
import GHC.Types.Tickish
import GHC.Core.Opt.SetLevels
@@ -222,11 +221,11 @@ floatBind (NonRec (TB var _) rhs)
-- A tiresome hack:
-- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels
--- let rhs'' | isDeadEndId var
--- , exprArity rhs' < idArity var = etaExpand (idArity var) rhs'
--- | otherwise = rhs'
+ let rhs'' | isDeadEndId var
+ , exprArity rhs' < idArity var = etaExpand (idArity var) rhs'
+ | otherwise = rhs'
- (fs, rhs_floats, [NonRec var rhs']) }
+ in (fs, rhs_floats, [NonRec var rhs'']) }
floatBind (Rec pairs)
= case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -301,8 +301,8 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs
| otherwise
= case bind_cxt of
- BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $
- simplJoinBind env is_rec cont old_bndr new_bndr rhs env
+ BC_Join cont -> simplTrace "SimplBind:join" (ppr old_bndr) $
+ simplJoinBind env cont old_bndr new_bndr rhs env
BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $
simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
@@ -385,17 +385,16 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
--------------------------
simplJoinBind :: SimplEnv
- -> RecFlag
-> SimplCont
-> InId -> OutId -- Binder, both pre-and post simpl
-- The OutId has IdInfo, except arity,
-- unfolding
-> InExpr -> SimplEnv -- The right hand side and its env
-> SimplM (SimplFloats, SimplEnv)
-simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se
+simplJoinBind env cont old_bndr new_bndr rhs rhs_se
= do { let rhs_env = rhs_se `setInScopeFromE` env
; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont
- ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' }
+ ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' }
--------------------------
simplNonRecX :: SimplEnv
@@ -1870,8 +1869,8 @@ simplNonRecJoinPoint env bndr rhs body cont
; let mult = contHoleScaling cont
res_ty = contResultType cont
; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
- ; (floats1, env3) <- simplJoinBind env2 NonRecursive cont bndr bndr2 rhs env
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join cont)
+ ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env
; (floats2, body') <- simplExprF env3 body cont
; return (floats1 `addFloats` floats2, body') }
@@ -1888,7 +1887,7 @@ simplRecJoinPoint env pairs body cont
; env1 <- simplRecJoinBndrs env bndrs mult res_ty
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
- ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs
+ ; (floats1, env2) <- simplRecBind env1 (BC_Join cont) pairs
; (floats2, body') <- simplExprF env2 body cont
; return (floats1 `addFloats` floats2, body') }
@@ -4150,9 +4149,9 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf
CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
| isStableSource src
-> do { expr' <- case bind_cxt of
- BC_Join _ cont -> -- Binder is a join point
- -- See Note [Rules and unfolding for join points]
- simplJoinRhs unf_env id expr cont
+ BC_Join cont -> -- Binder is a join point
+ -- See Note [Rules and unfolding for join points]
+ simplJoinRhs unf_env id expr cont
BC_Let _ is_rec -> -- Binder is not a join point
do { let cont = mkRhsStop rhs_ty is_rec topDmd
-- mkRhsStop: switch off eta-expansion at the top level
@@ -4205,7 +4204,6 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf
-- See Note [Eta-expand stable unfoldings]
-- Use the arity from the main Id (in id_arity), rather than computing it from rhs
- -- Not used for join points
eta_expand expr | seEtaExpand env
, exprArity expr < arityTypeArity id_arity
, wantEtaExpansion expr
@@ -4244,7 +4242,7 @@ Wrinkles
* Don't eta-expand join points; see Note [Do not eta-expand join points]
in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point
- case (bind_cxt = BC_Join {}) doesn't use eta_expand.
+ case (bind_cxt = BC_Join _) doesn't use eta_expand.
Note [Force bottoming field]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -4317,8 +4315,8 @@ simplRules env mb_new_id rules bind_cxt
= do { (env', bndrs') <- simplBinders env bndrs
; let rhs_ty = substTy env' (exprType rhs)
rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points]
- BC_Let {} -> mkBoringStop rhs_ty
- BC_Join _ cont -> assertPpr join_ok bad_join_msg cont
+ BC_Let {} -> mkBoringStop rhs_ty
+ BC_Join cont -> assertPpr join_ok bad_join_msg cont
lhs_env = updMode updModeForRules env'
rhs_env = updMode (updModeForStableUnfoldings act) env'
-- See Note [Simplifying the RHS of a RULE]
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -95,8 +95,8 @@ data BindContext
TopLevelFlag RecFlag
| BC_Join -- A join point with continuation k
- RecFlag -- See Note [Rules and unfolding for join points]
- SimplCont -- in GHC.Core.Opt.Simplify
+ SimplCont -- See Note [Rules and unfolding for join points]
+ -- in GHC.Core.Opt.Simplify
bindContextLevel :: BindContext -> TopLevelFlag
bindContextLevel (BC_Let top_lvl _) = top_lvl
@@ -1779,20 +1779,18 @@ tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr
-- 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
- | isJoinId 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
+tryEtaExpandRhs _env (BC_Join {}) bndr rhs
+ | Just join_arity <- isJoinId_maybe bndr
+ = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
+ arity_type = mkManifestArityType join_bndrs join_body
+ ; 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
| otherwise
= pprPanic "tryEtaExpandRhs" (ppr bndr)
- where
- old_arity = exprArity rhs
- arity_type = findRhsArity arity_opts is_rec bndr rhs old_arity
- arity_opts = seArityOpts env
tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs
| seEtaExpand env -- Provided eta-expansion is on
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3993bbb202499fdef3292f9e34c929d96db4529c...85048c986d6b8763f818de8e46c9b979f056e3e7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3993bbb202499fdef3292f9e34c929d96db4529c...85048c986d6b8763f818de8e46c9b979f056e3e7
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/20220818/a87283a3/attachment-0001.html>
More information about the ghc-commits
mailing list