[Git][ghc/ghc][wip/T21694a] More improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Aug 19 22:50:20 UTC 2022
Simon Peyton Jones pushed to branch wip/T21694a at Glasgow Haskell Compiler / GHC
Commits:
1f142834 by Simon Peyton Jones at 2022-08-19T23:49:51+01:00
More improvements
Get rid of the AnalysisMode from ArityEnv; not needed any more.
Enhance cheapArityType.
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -137,28 +137,6 @@ joinRhsArity (Lam _ e) = 1 + joinRhsArity e
joinRhsArity _ = 0
----------------
-exprArity :: CoreExpr -> Arity
--- ^ An approximate, fast, version of 'exprEtaExpandArity'
--- We do /not/ guarantee that exprArity e <= typeArity e
--- You may need to do arity trimming after calling exprArity
--- See Note [Arity trimming]
--- 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
- go (Lam x e) | isId x = go e + 1
- | otherwise = go e
- go (Tick t e) | not (tickishIsCode t) = go e
- go (Cast e _) = go e
- go (App e (Type _)) = go e
- go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
- -- See Note [exprArity for applications]
- -- NB: coercions count as a value argument
-
- go _ = 0
-
---------------
exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig)
-- A cheap and cheerful function that identifies bottoming functions
@@ -1264,71 +1242,35 @@ dictionary-typed expression, but that's more work.
---------------------------
--- | Each of the entry-points of the analyser ('arityType') has different
--- requirements. The entry-points are
---
--- 1. 'exprBotStrictness_maybe'
--- 2. 'exprEtaExpandArity'
--- 3. 'findRhsArity'
---
--- For each of the entry-points, there is a separate mode that governs
---
--- 1. How pedantic we are wrt. ⊥, in 'pedanticBottoms'.
--- 2. Whether we store arity signatures for non-recursive let-bindings,
--- accessed in 'extendSigEnv'/'lookupSigEnv'.
--- See Note [Arity analysis] why that's important.
--- 3. Which expressions we consider cheap to float inside a lambda,
--- in 'myExprIsCheap'.
-data AnalysisMode
- = BotStrictness
- -- ^ Used during 'exprBotStrictness_maybe'.
-
- | FindRhsArity { am_opts :: !ArityOpts
- , am_no_eta :: !Bool
- , am_sigs :: !(IdEnv SafeArityType) }
- -- ^ Used for regular, fixed-point arity analysis ('findRhsArity').
- -- See Note [Arity analysis] for details about fixed-point iteration.
+data ArityEnv
+ = AE { am_opts :: !ArityOpts
+ , am_no_eta :: !Bool
+ , 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 type for recursive join bindings]
-- point 5
-data ArityEnv
- = AE
- { ae_mode :: !AnalysisMode
- -- ^ 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 }
+ ppr (AE { am_sigs = sigs, am_no_eta = no_eta })
+ = text "AE" <+> braces (sep [ text "no-eta" <+> ppr no_eta
+ , text "sigs" <+> ppr sigs ])
-- | The @ArityEnv@ used by 'findRhsArity'.
findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv
findRhsArityEnv opts no_eta
- = AE { ae_mode = FindRhsArity { am_opts = opts
- , am_no_eta = no_eta
- , am_sigs = emptyVarEnv } }
+ = AE { 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
+isNoEtaEnv (AE { am_no_eta = no_eta }) = no_eta
-- 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 _ env = env
+modifySigEnv f env@(AE { am_sigs = sigs }) = env { am_sigs = f sigs }
{-# INLINE modifySigEnv #-}
del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal!
@@ -1353,16 +1295,12 @@ delInScopeList :: ArityEnv -> [Id] -> ArityEnv
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
- FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id
+lookupSigEnv (AE { am_sigs = sigs }) id = lookupVarEnv sigs id
-- | Whether the analysis should be pedantic about bottoms.
-- 'exprBotStrictness_maybe' always is.
pedanticBottoms :: ArityEnv -> Bool
-pedanticBottoms AE{ ae_mode = mode } = case mode of
- BotStrictness -> True
- FindRhsArity{ am_opts = ArityOpts{ ao_ped_bot = ped_bot } } -> ped_bot
+pedanticBottoms (AE { am_opts = ArityOpts{ ao_ped_bot = ped_bot }}) = ped_bot
exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost
exprCost env e mb_ty
@@ -1373,22 +1311,17 @@ exprCost env e mb_ty
-- and optionally the expression's type.
-- Under 'exprBotStrictness_maybe', no expressions are cheap.
myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool
-myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of
- BotStrictness -> False
- _ -> cheap_dict || cheap_fun e
- where
- cheap_dict = case mb_ty of
+myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty
+ = cheap_dict || cheap_fun e
+ where
+ cheap_dict = case mb_ty of
Nothing -> False
- Just ty -> (ao_dicts_cheap (am_opts mode) && isDictTy ty)
+ Just ty -> (ao_dicts_cheap opts && isDictTy ty)
|| isCallStackPredTy ty
-- See Note [Eta expanding through dictionaries]
-- See Note [Eta expanding through CallStacks]
- cheap_fun e = case mode of
-#if __GLASGOW_HASKELL__ <= 900
- BotStrictness -> panic "impossible"
-#endif
- FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) e
+ cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e
-- | A version of 'isCheapApp' that considers results from arity analysis.
-- See Note [Arity analysis] for what's in the signature environment and why
@@ -1495,20 +1428,76 @@ arityType env (Tick t e)
arityType _ _ = topArityType
+--------------------
+idArityType :: Id -> ArityType
+idArityType v
+ | strict_sig <- idDmdSig v
+ , (ds, div) <- splitDmdSig strict_sig
+ , isDeadEndDiv div
+ = AT (takeList ds one_shots) div
+
+ | isEmptyTy id_ty
+ = botArityType
+
+ | otherwise
+ = AT (take (idArity v) one_shots) topDiv
+ where
+ id_ty = idType v
+
+ one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type
+ one_shots = repeat IsCheap `zip` typeOneShots id_ty
+
--------------------
cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType
-cheapArityType (Lam var body)
- | isTyVar var = body_at
- | otherwise = AT ((IsCheap, idOneShotInfo var) : lams) div
+-- Returns ArityType with IsCheap everywhere
+cheapArityType e = go e
where
- !body_at@(AT lams div) = cheapArityType body
+ go (Var v) = idArityType v
+ go (Cast e _) = go e
+ go (Lam x e) | isId x = arityLam x (go e)
+ | otherwise = go e
+ go (App f a) | isTypeArg a = go f
+ | otherwise = arity_app a (go e)
-cheapArityType e
- | exprIsDeadEnd e = botArityType
- | otherwise = AT lams topDiv
+ go (Tick t e) | not (tickishIsCode t) = go e
+
+ -- Null alts: see Note [Empty case alternatives] in GHC.Core
+ go (Case _ _ _ alts) | null alts = botArityType
+
+ -- Give up on let, case
+ go _ = topArityType
+
+ -- Specialised version of arityApp; all costs in ArityType are IsCheap
+ -- 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
+ | exprIsTrivial arg = AT lams topDiv
+ | otherwise = topArityType
+
+---------------
+exprArity :: CoreExpr -> Arity
+-- ^ An approximate, fast, version of 'exprEtaExpandArity'
+-- We do /not/ guarantee that exprArity e <= typeArity e
+-- You may need to do arity trimming after calling exprArity
+-- See Note [Arity trimming]
+-- 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
- lams = replicate (exprArity e) (IsCheap, NoOneShotInfo)
+ go (Var v) = idArity v
+ go (Lam x e) | isId x = go e + 1
+ | otherwise = go e
+ go (Tick t e) | not (tickishIsCode t) = go e
+ go (Cast e _) = go e
+ go (App e (Type _)) = go e
+ go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
+ -- See Note [exprArity for applications]
+ -- NB: coercions count as a value argument
+
+ go _ = 0
{- Note [No free join points in arityType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1646,20 +1635,6 @@ Obviously `f` should get arity 4. But it's a bit tricky:
the flag is on, we allow free join points, but not otherwise.
-}
-idArityType :: Id -> ArityType
-idArityType v
- | strict_sig <- idDmdSig v
- , (ds, div) <- splitDmdSig strict_sig
- , isDeadEndDiv div
- , let arity = length ds
- = AT (take arity one_shots) div
-
- | otherwise
- = AT (take (idArity v) one_shots) topDiv
- where
- one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type
- one_shots = repeat IsCheap `zip` typeOneShots (idType v)
-
{-
%************************************************************************
%* *
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -117,8 +117,7 @@ tidyCbvInfoTop boot_exports id rhs
-- See Note [CBV Function Ids]
tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id
-tidyCbvInfoLocal id rhs
- | otherwise = computeCbvInfo id rhs
+tidyCbvInfoLocal id rhs = computeCbvInfo id rhs
-- | For a binding we:
-- * Look at the args
@@ -135,9 +134,9 @@ computeCbvInfo :: HasCallStack
-> Id
-- computeCbvInfo fun_id rhs = fun_id
computeCbvInfo fun_id rhs
- | (isWorkerLike || isJoinId fun_id) && (valid_unlifted_worker val_args)
- =
- -- pprTrace "computeCbvInfo"
+ | is_wkr_like || isJust mb_join_id
+ , valid_unlifted_worker val_args
+ = -- pprTrace "computeCbvInfo"
-- (text "fun" <+> ppr fun_id $$
-- text "arg_tys" <+> ppr (map idType val_args) $$
@@ -146,31 +145,48 @@ computeCbvInfo fun_id rhs
-- text "cbv_marks" <+> ppr cbv_marks $$
-- text "out_id" <+> ppr cbv_bndr $$
-- ppr rhs)
- cbv_bndr
+ cbv_bndr
+
| otherwise = fun_id
where
- val_args = filter isId . fst $ collectBinders rhs
- cbv_marks =
- -- CBV marks are only set during tidy so none should be present already.
- assertPpr (maybe True null $ idCbvMarks_maybe fun_id) (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $
- map mkMark val_args
- cbv_bndr
- | valid_unlifted_worker val_args
- , any isMarkedCbv cbv_marks
- -- seqList to avoid retaining the original rhs
- = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks
- | otherwise =
- -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" (ppr fun_id <+> ppr rhs)
- asNonWorkerLikeId fun_id
- -- We don't set CBV marks on functions which take unboxed tuples or sums as arguments.
- -- Doing so would require us to compute the result of unarise here in order to properly determine
- -- argument positions at runtime.
- -- In practice this doesn't matter much. Most "interesting" functions will get a W/W split which will eliminate
- -- unboxed tuple arguments, and unboxed sums are rarely used. But we could change this in the future and support
+ mb_join_id = isJoinId_maybe fun_id
+ is_wkr_like = isWorkerLikeId fun_id
+
+ val_args = filter isId lam_bndrs
+ -- When computing CbvMarks, we limit the arity of join points to
+ -- the JoinArity, because that's the arity we are going to use
+ -- when calling it. There may be more lambdas than that on the RHS.
+ lam_bndrs | Just join_arity <- mb_join_id
+ = fst $ collectNBinders join_arity rhs
+ | otherwise
+ = fst $ collectBinders rhs
+
+ cbv_marks = -- assert: CBV marks are only set during tidy so none should be present already.
+ assertPpr (maybe True null $ idCbvMarks_maybe fun_id)
+ (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $
+ map mkMark val_args
+
+ cbv_bndr | any isMarkedCbv cbv_marks
+ = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks
+ -- seqList: avoid retaining the original rhs
+
+ | otherwise
+ = -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!"
+ -- (ppr fun_id <+> ppr rhs)
+ asNonWorkerLikeId fun_id
+
+ -- We don't set CBV marks on functions which take unboxed tuples or sums as
+ -- arguments. Doing so would require us to compute the result of unarise
+ -- here in order to properly determine argument positions at runtime.
+ --
+ -- In practice this doesn't matter much. Most "interesting" functions will
+ -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed
+ -- sums are rarely used. But we could change this in the future and support
-- unboxed sums/tuples as well.
valid_unlifted_worker args =
-- pprTrace "valid_unlifted" (ppr fun_id $$ ppr args) $
all isSingleUnarisedArg args
+
isSingleUnarisedArg v
| isUnboxedSumType ty = False
| isUnboxedTupleType ty = isSimplePrimRep (typePrimRep ty)
@@ -188,7 +204,6 @@ computeCbvInfo fun_id rhs
, not (isDeadEndId fun_id) = MarkedCbv
| otherwise = NotMarkedCbv
- isWorkerLike = isWorkerLikeId fun_id
------------ Expressions --------------
tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
@@ -339,7 +354,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id
new_info = vanillaIdInfo
`setOccInfo` occInfo old_info
`setArityInfo` arityInfo old_info
- `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info)
+ `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info)
`setDemandInfo` demandInfo old_info
`setInlinePragInfo` inlinePragInfo old_info
`setUnfoldingInfo` new_unf
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1085,6 +1085,8 @@ exprIsDeadEnd :: CoreExpr -> Bool
exprIsDeadEnd e
= go 0 e
where
+ go :: Arity -> CoreExpr -> Bool
+ -- (go n e) = True <=> expr applied to n value args is bottom
go _ (Lit {}) = False
go _ (Type {}) = False
go _ (Coercion {}) = False
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1f142834b9c06636d08749bf74f4f45e60c5c057
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1f142834b9c06636d08749bf74f4f45e60c5c057
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/406dbea5/attachment-0001.html>
More information about the ghc-commits
mailing list