diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/Arity.hs | 34 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 15 |
3 files changed, 34 insertions, 27 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index c95379cc4d..623b2bf74a 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -140,7 +140,8 @@ exprArity :: CoreExpr -> Arity -- We do /not/ guarantee that exprArity e <= typeArity e -- You may need to do arity trimming after calling exprArity -- See Note [Arity trimming] --- (If we do arity trimming here we have to do it at every cast. +-- Reason: if we do arity trimming here we have take exprType +-- and that can be expensive if there is a large cast exprArity e = go e where go (Var v) = idArity v @@ -291,7 +292,11 @@ on the argument type to access the "state hack". We have the following invariants around typeArity (1) In any binding x = e, - idArity f <= typeArity (idType f) + idArity f <= typeArity (idType f) + Note that we enforce this only for /bindings/. We do /not/ insist that + arityTypeArity (arityType e) <= typeArity (exprType e) + because that is quite a bit more expensive to guaranteed; it would + mean checking at every Cast in the recursive arityType, for example. (2) If typeArity (exprType e) = n, then manifestArity (etaExpand e n) = n @@ -305,7 +310,7 @@ Why is this important? Because each top-level Id, and in - In CorePrep we use etaExpand on each rhs, so that the visible lambdas - actually match that arity, which in turn means + Actually match that arity, which in turn means that the StgRhs has the right number of lambdas Suppose we have @@ -329,9 +334,9 @@ and handle what typeArity says. Note [Arity trimming] ~~~~~~~~~~~~~~~~~~~~~ -Arity trimming, implemented by trimArityType, directly implements -invariant (1) of Note [typeArity invariants]. Failing to do so, and -hence breaking invariant (1) led to #5441. +Invariant (1) of Note [typeArity invariants] is upheld by findRhsArity, +which calls trimArityType to trim the ArityType to match the Arity of the +binding. Failing to do so, and hence breaking invariant (1) led to #5441. How to trim? If we end in topDiv, it's easy. But we must take great care with dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), @@ -654,14 +659,16 @@ ArityType 'at', then * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@ definitely diverges. Partial applications to fewer than n args may *or - may not* diverge. + may not* diverge. Ditto exnDiv. We allow ourselves to eta-expand bottoming functions, even if doing so may lose some `seq` sharing, let x = <expensive> in \y. error (g x y) ==> \y. let x = <expensive> in error (g x y) - * If `f` has ArityType `at` we can eta-expand `f` by (aritTypeOneShots at) + See getBotArity. + + * If `f` has ArityType `at` we can eta-expand `f` to have (aritTypeOneShots at) arguments without losing sharing. This function checks that the either there are no expensive expressions, or the lambdas are one-shots. @@ -837,8 +844,7 @@ findRhsArity :: DynFlags -> RecFlag -> Id -> CoreExpr -> Arity -> ArityType -- (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' --- See Note [Arity trimming] --- +-- See Note [Arity trimming] findRhsArity dflags is_rec bndr rhs old_arity = case is_rec of Recursive -> go 0 botArityType @@ -2119,9 +2125,11 @@ tryEtaReduce bndrs body go remaining_bndrs fun co | all isTyVar remaining_bndrs - -- We might have /\a \b. f [a] b, and we want to - -- eta-reduce to /\a. f [a] - -- See #20040 + -- If all the remaining_bnrs are tyvars, then the etad_exp + -- will be trivial, which is what we want. + -- e.g. We might have /\a \b. f [a] b, and we want to + -- eta-reduce to /\a. f [a] + -- We don't want to give up on this one: see #20040 , remaining_bndrs `ltLength` bndrs -- Only reply Just if /something/ has happened , all ok_lam bndrs || ok_fun fun diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index e92d6d1032..016ea1b25f 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -386,7 +386,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se ; return (poly_floats, body3) } ; let env' = env `setInScopeFromF` rhs_floats - ; rhs' <- rebuildLam env' tvs' body3 rhs_cont + ; rhs' <- rebuildLam env' tvs' body3 (Just is_rec) ; (bind_float, env2) <- completeBind env' top_lvl is_rec Nothing bndr bndr1 rhs' ; return (rhs_floats `addFloats` bind_float, env2) } @@ -948,7 +948,7 @@ addLetBndrInfo new_bndr new_arity_type new_unf -- Bottoming bindings: see Note [Bottoming bindings] info4 | isDeadEndDiv div = info3 `setDmdSigInfo` bot_sig - `setCprSigInfo` bot_cpr + `setCprSigInfo` bot_cpr | otherwise = info3 bot_sig = mkClosedDmdSig (replicate new_arity topDmd) div @@ -966,12 +966,12 @@ Suppose we have let x = error "urk" in ...(case x of <alts>)... or - let f = \x. error (x ++ "urk") + let f = \y. error (y ++ "urk") in ...(case f "foo" of <alts>)... Then we'd like to drop the dead <alts> immediately. So it's good to -propagate the info that x's RHS is bottom to x's IdInfo as rapidly as -possible. +propagate the info that x's (or f's) RHS is bottom to x's (or f's) +IdInfo as rapidly as possible. We use tryEtaExpandRhs on every binding, and it turns out that the arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already @@ -1626,7 +1626,7 @@ simplLam env bndrs body (TickIt tickish cont) simplLam env bndrs body cont = do { (env', bndrs') <- simplLamBndrs env bndrs ; body' <- simplExpr env' body - ; new_lam <- rebuildLam env' bndrs' body' cont + ; new_lam <- rebuildLam env' bndrs' body' (contIsRhs cont) ; rebuild env new_lam cont } ------------- diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index b8c483aa50..9fcc1f079e 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -21,7 +21,7 @@ module GHC.Core.Opt.Simplify.Utils ( SimplCont(..), DupFlag(..), StaticEnv, isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, + contIsTrivial, contArgs, contIsRhs, countArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, @@ -1562,7 +1562,8 @@ won't inline because 'e' is too big. rebuildLam :: SimplEnv -> [OutBndr] -> OutExpr - -> SimplCont -> SimplM OutExpr + -> Maybe RecFlag -- Just => lambda is the RHS of a let(rec) + -> SimplM OutExpr -- (rebuildLam env bndrs body cont) -- returns expr which means the same as \bndrs. body -- @@ -1572,16 +1573,14 @@ rebuildLam :: SimplEnv -- -- NB: the SimplEnv already includes the [OutBndr] in its in-scope set -rebuildLam _env [] body _cont +rebuildLam _env [] body _mb_rhs = return body -rebuildLam env bndrs body cont - = do { dflags <- getDynFlags +rebuildLam env bndrs body mb_rhs + = {-# SCC "rebuildLam" #-} + do { dflags <- getDynFlags ; try_eta dflags bndrs body } where - mb_rhs :: Maybe RecFlag -- Just => continuation is the RHS of a let - mb_rhs = contIsRhs cont - in_scope = getInScope env -- Includes 'bndrs' try_eta :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr |