[Git][ghc/ghc][wip/T21694a] Efficency improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Aug 19 15:25:57 UTC 2022
Simon Peyton Jones pushed to branch wip/T21694a at Glasgow Haskell Compiler / GHC
Commits:
233089bd by Simon Peyton Jones at 2022-08-19T16:26:46+01:00
Efficency improvements
Don't call full arityType for non-rec join points
(must document this).
Refactoring
- - - - -
5 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Iface/Tidy.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -13,7 +13,7 @@
module GHC.Core.Opt.Arity
( -- Finding arity
manifestArity, joinRhsArity, exprArity
- , findRhsArity, exprBotStrictness_maybe
+ , findRhsArity, cheapArityType
, ArityOpts(..)
-- ** Eta expansion
@@ -24,7 +24,10 @@ module GHC.Core.Opt.Arity
-- ** ArityType
, ArityType, mkBotArityType
- , arityTypeArity, idArityType, getBotArity
+ , arityTypeArity, idArityType
+
+ -- ** Bottoming things
+ , exprBotStrictness_maybe, arityTypeBotSigs_maybe
-- ** typeArity and the state hack
, typeArity, typeOneShots, typeOneShot
@@ -63,6 +66,7 @@ import GHC.Core.Type as Type
import GHC.Core.Coercion as Type
import GHC.Types.Demand
+import GHC.Types.Cpr( CprSig, mkCprSig, botCpr )
import GHC.Types.Id
import GHC.Types.Var.Env
import GHC.Types.Var.Set
@@ -156,14 +160,22 @@ exprArity e = go e
go _ = 0
---------------
-exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig)
+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig)
-- A cheap and cheerful function that identifies bottoming functions
--- and gives them a suitable strictness signatures. It's used during
--- float-out
-exprBotStrictness_maybe e
- = case getBotArity (arityType botStrictnessArityEnv e) of
- Nothing -> Nothing
- Just ar -> Just (ar, mkVanillaDmdSig ar botDiv)
+-- and gives them a suitable strictness and CPR signatures.
+-- It's used during float-out
+exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e)
+
+arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig)
+-- Arity of a divergent function
+arityTypeBotSigs_maybe (AT lams div)
+ | isDeadEndDiv div = Just ( arity
+ , mkVanillaDmdSig arity botDiv
+ , mkCprSig arity botCpr)
+ | otherwise = Nothing
+ where
+ arity = length lams
+
{- Note [exprArity for applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -467,7 +479,14 @@ We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.
Note [Dealing with bottom]
~~~~~~~~~~~~~~~~~~~~~~~~~~
-A Big Deal with computing arities is expressions like
+GHC does some transformations that are technically unsound wrt
+bottom, because doing so improves arities... a lot! We describe
+them in this Note.
+
+The flag -fpedantic-bottoms (off by default) restore technically
+correct behaviour at the cots of efficiency.
+
+It's mostly to do with eta-expansion. Consider
f = \x -> case x of
True -> \s -> e1
@@ -487,7 +506,7 @@ would lose an important transformation for many programs. (See
Consider also
f = \x -> error "foo"
-Here, arity 1 is fine. But if it is
+Here, arity 1 is fine. But if it looks like this (see #22068)
f = \x -> case x of
True -> error "foo"
False -> \y -> x+y
@@ -869,12 +888,6 @@ exprEtaExpandArity opts e
where
arity_type = safeArityType (arityType (findRhsArityEnv opts False) e)
-getBotArity :: ArityType -> Maybe Arity
--- Arity of a divergent function
-getBotArity (AT oss div)
- | isDeadEndDiv div = Just $ length oss
- | otherwise = Nothing
-
{- *********************************************************************
* *
@@ -923,13 +936,13 @@ findRhsArity opts is_rec bndr rhs old_arity
go !n cur_at@(AT lams div)
| not (isDeadEndDiv div) -- the "stop right away" case
, length lams <= old_arity = cur_at -- from above
- | next_at == cur_at = cur_at
- | otherwise =
+ | next_at == cur_at = cur_at
+ | otherwise
-- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]
- warnPprTrace (debugIsOn && n > 2)
+ = warnPprTrace (debugIsOn && n > 2)
"Exciting arity"
(nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $
- go (n+1) next_at
+ go (n+1) next_at
where
next_at = step (extendSigEnv init_env bndr cur_at)
@@ -1294,8 +1307,8 @@ instance Outputable AnalysisMode where
-- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms
-- and no application is ever considered cheap.
-botStrictnessArityEnv :: ArityEnv
-botStrictnessArityEnv = AE { ae_mode = BotStrictness }
+_botStrictnessArityEnv :: ArityEnv
+_botStrictnessArityEnv = AE { ae_mode = BotStrictness }
-- | The @ArityEnv@ used by 'findRhsArity'.
findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv
@@ -1482,6 +1495,20 @@ arityType env (Tick t e)
arityType _ _ = topArityType
+--------------------
+cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType
+
+cheapArityType (Lam var body)
+ | isTyVar var = body_at
+ | otherwise = AT ((IsCheap, idOneShotInfo var) : lams) div
+ where
+ !body_at@(AT lams div) = cheapArityType body
+
+cheapArityType e
+ | exprIsDeadEnd e = botArityType
+ | otherwise = AT lams topDiv
+ where
+ lams = replicate (exprArity e) (IsCheap, NoOneShotInfo)
{- Note [No free join points in arityType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1579,7 +1606,8 @@ Obviously `f` should get arity 4. But it's a bit tricky:
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,
+ 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` (Note [arityType for let-bindings])
- At the occurrence (j 20) that arity-4 ArityType will leave an arity-3
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -104,7 +104,7 @@ import GHC.Types.Unique.DSet ( getUniqDSet )
import GHC.Types.Var.Env
import GHC.Types.Literal ( litIsTrivial )
import GHC.Types.Demand ( DmdSig, prependArgsDmdSig )
-import GHC.Types.Cpr ( mkCprSig, botCpr )
+import GHC.Types.Cpr ( CprSig, prependArgsCprSig )
import GHC.Types.Name ( getOccName, mkSystemVarName )
import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Unique ( hasKey )
@@ -659,9 +659,7 @@ lvlMFE env strict_ctxt ann_expr
-- No wrapping needed if the type is lifted, or is a literal string
-- or if we are wrapping it in one or more value lambdas
= do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
- (isJust mb_bot_str)
- join_arity_maybe
- ann_expr
+ is_bot_lam join_arity_maybe ann_expr
-- Treat the expr just like a right-hand side
; var <- newLvlVar expr1 join_arity_maybe is_mk_static
; let var2 = annotateBotStr var float_n_lams mb_bot_str
@@ -702,6 +700,7 @@ lvlMFE env strict_ctxt ann_expr
fvs = freeVarsOf ann_expr
fvs_ty = tyCoVarsOfType expr_ty
is_bot = isBottomThunk mb_bot_str
+ is_bot_lam = isJust mb_bot_str
is_function = isFunction ann_expr
mb_bot_str = exprBotStrictness_maybe expr
-- See Note [Bottoming floats]
@@ -750,10 +749,10 @@ hasFreeJoin :: LevelEnv -> DVarSet -> Bool
hasFreeJoin env fvs
= not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
-isBottomThunk :: Maybe (Arity, s) -> Bool
+isBottomThunk :: Maybe (Arity, DmdSig, CprSig) -> Bool
-- See Note [Bottoming floats] (2)
-isBottomThunk (Just (0, _)) = True -- Zero arity
-isBottomThunk _ = False
+isBottomThunk (Just (0, _, _)) = True -- Zero arity
+isBottomThunk _ = False
{- Note [Floating to the top]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1008,17 +1007,18 @@ answer.
-}
-annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id
+annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id
-- See Note [Bottoming floats] for why we want to add
-- bottoming information right now
--
-- n_extra are the number of extra value arguments added during floating
-annotateBotStr id n_extra mb_str
- = case mb_str of
- Nothing -> id
- Just (arity, sig) -> id `setIdArity` (arity + n_extra)
- `setIdDmdSig` prependArgsDmdSig n_extra sig
- `setIdCprSig` mkCprSig (arity + n_extra) botCpr
+annotateBotStr id n_extra mb_bot_str
+ | Just (arity, str_sig, cpr_sig) <- mb_bot_str
+ = id `setIdArity` (arity + n_extra)
+ `setIdDmdSig` prependArgsDmdSig n_extra str_sig
+ `setIdCprSig` prependArgsCprSig n_extra cpr_sig
+ | otherwise
+ = id
notWorthFloating :: CoreExpr -> [Var] -> Bool
-- Returns True if the expression would be replaced by
@@ -1127,7 +1127,7 @@ lvlBind env (AnnNonRec bndr rhs)
-- bit brutal, but unlifted bindings aren't expensive either
= -- No float
- do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs
+ do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs
; let bind_lvl = incMinorLvl (le_ctxt_lvl env)
(env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
; return (NonRec bndr' rhs', env') }
@@ -1136,7 +1136,7 @@ lvlBind env (AnnNonRec bndr rhs)
| null abs_vars
= do { -- No type abstraction; clone existing binder
rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive
- is_bot mb_join_arity rhs
+ is_bot_lam mb_join_arity rhs
; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
@@ -1144,7 +1144,7 @@ lvlBind env (AnnNonRec bndr rhs)
| otherwise
= do { -- Yes, type abstraction; create a new binder, extend substitution, etc
rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive
- is_bot mb_join_arity rhs
+ is_bot_lam mb_join_arity rhs
; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
@@ -1155,11 +1155,12 @@ lvlBind env (AnnNonRec bndr rhs)
rhs_fvs = freeVarsOf rhs
bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr
abs_vars = abstractVars dest_lvl env bind_fvs
- dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join
+ dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam is_join
deann_rhs = deAnnotate rhs
mb_bot_str = exprBotStrictness_maybe deann_rhs
- is_bot = isJust mb_bot_str
+ is_bot_lam = isJust mb_bot_str
+ -- is_bot_lam: looks like (\xy. bot), maybe zero lams
-- NB: not isBottomThunk! See Note [Bottoming floats] point (3)
n_extra = count isId abs_vars
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -38,7 +38,7 @@ import GHC.Core.Ppr ( pprCoreExpr )
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Utils
-import GHC.Core.Opt.Arity ( ArityType, exprArity, getBotArity
+import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe
, pushCoTyArg, pushCoValArg
, typeArity, arityTypeArity, etaExpandAT )
import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
@@ -53,7 +53,6 @@ import GHC.Types.Id.Make ( seqId )
import GHC.Types.Id.Info
import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS )
import GHC.Types.Demand
-import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Types.Unique ( hasKey )
import GHC.Types.Basic
import GHC.Types.Tickish
@@ -980,11 +979,11 @@ addLetBndrInfo new_bndr new_arity_type new_unf
= info2
-- Bottoming bindings: see Note [Bottoming bindings]
- info4 = case getBotArity new_arity_type of
+ info4 = case arityTypeBotSigs_maybe new_arity_type of
Nothing -> info3
- Just ar -> assert (ar == new_arity) $
- info3 `setDmdSigInfo` mkVanillaDmdSig new_arity botDiv
- `setCprSigInfo` mkCprSig new_arity botCpr
+ Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $
+ info3 `setDmdSigInfo` str_sig
+ `setCprSigInfo` cpr_sig
-- Zap call arity info. We have used it by now (via
-- `tryEtaExpandRhs`), and the simplifier can invalidate this
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1780,19 +1780,17 @@ tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr
-- (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)
+ = 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
-
- | 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
+ 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
@@ -1805,8 +1803,8 @@ tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs
= return (arity_type, rhs)
where
in_scope = getInScope env
- arity_opts = seArityOpts 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
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -1274,21 +1274,22 @@ tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unf
-- No demand signature, so try a
-- cheap-and-cheerful bottom analyser
- | Just (_, nsig) <- mb_bot_str
- = nsig
+ | Just (_, bot_str_sig, _) <- mb_bot_str
+ = bot_str_sig
-- No stricness info
| otherwise = nopSig
cpr = cprSigInfo idinfo
- final_cpr | Just _ <- mb_bot_str
- = mkCprSig arity botCpr
+ final_cpr | Just (_, _, bot_cpr_sig) <- mb_bot_str
+ = bot_cpr_sig
| otherwise
= cpr
- _bottom_hidden id_sig = case mb_bot_str of
- Nothing -> False
- Just (arity, _) -> not (isDeadEndAppSig id_sig arity)
+ _bottom_hidden id_sig
+ = case mb_bot_str of
+ Nothing -> False
+ Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity)
--------- Unfolding ------------
unf_info = realUnfoldingInfo idinfo
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/233089bd7623d80ad43154c9bed71f1cd86dc184
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/233089bd7623d80ad43154c9bed71f1cd86dc184
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/20220819/3b1db216/attachment-0001.html>
More information about the ghc-commits
mailing list