diff options
Diffstat (limited to 'compiler/GHC/Core')
33 files changed, 656 insertions, 164 deletions
diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index e4663ad075..89ca7319f7 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -267,7 +267,7 @@ expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr (mapUnionFV alt_fvs alts)) fv_cand in_scope acc where - alt_fvs (Alt _ bndrs rhs) = addBndrs bndrs (expr_fvs rhs) + alt_fvs (Alt _ _ bndrs rhs) = addBndrs bndrs (expr_fvs rhs) expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) @@ -325,7 +325,7 @@ exprOrphNames e go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty `unionNameSet` unionNameSets (map go_alt as) - go_alt (Alt _ _ r) = go r + go_alt (Alt _ _ _ r) = go r -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details exprsOrphNames :: [CoreExpr] -> NameSet @@ -756,10 +756,10 @@ freeVars = go (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts alts_fvs = unionFVss alts_fvs_s - fv_alt (Alt con args rhs) = (delBindersFV args (freeVarsOf rhs2), - (AnnAlt con args rhs2)) - where - rhs2 = go rhs + fv_alt (Alt con freq args rhs) = (delBindersFV args (freeVarsOf rhs2), + (AnnAlt con freq args rhs2)) + where + rhs2 = go rhs go (Let bind body) = (bind_fvs, AnnLet bind2 body2) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 3b3a7232c0..ddad37bc6e 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1320,8 +1320,8 @@ lintCaseExpr scrut var alt_ty alts = -- if there are any literal alternatives -- See GHC.Core Note [Case expression invariants] item (5) -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold - ; let isLitPat (Alt (LitAlt _) _ _) = True - isLitPat _ = False + ; let isLitPat (Alt (LitAlt _) _ _ _) = True + isLitPat _ = False ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)." $$ text "scrut" <+> ppr scrut) @@ -1384,8 +1384,8 @@ checkCaseAlts e ty alts = increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest increasing_tag _ = True - non_deflt (Alt DEFAULT _ _) = False - non_deflt _ = True + non_deflt (Alt DEFAULT _ _ _) = False + non_deflt _ = True is_infinite_ty = case tyConAppTyCon_maybe ty of Nothing -> False @@ -1406,11 +1406,11 @@ lintCoreAlt :: Var -- Case binder -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintCoreAlt _ _ _ alt_ty (Alt DEFAULT args rhs) = +lintCoreAlt _ _ _ alt_ty (Alt DEFAULT _freq args rhs) = do { lintL (null args) (mkDefaultArgsMsg args) ; lintAltExpr rhs alt_ty } -lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) +lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) _freq args rhs) | litIsLifted lit = failWithL integerScrutinisedMsg | otherwise @@ -1420,7 +1420,7 @@ lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) where lit_ty = literalType lit -lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) +lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) _freq args rhs) | isNewTyCon (dataConTyCon con) = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty @@ -2969,10 +2969,10 @@ dumpLoc (BodyOfLetRec bs@(_:_)) dumpLoc (AnExpr e) = (noSrcLoc, text "In the expression:" <+> ppr e) -dumpLoc (CaseAlt (Alt con args _)) +dumpLoc (CaseAlt (Alt con _ args _)) = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) -dumpLoc (CasePat (Alt con args _)) +dumpLoc (CasePat (Alt con _ args _)) = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) dumpLoc (CaseTy scrut) diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index d7a78b5888..029bf7c90a 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -225,7 +225,7 @@ mkWildCase scrut (Scaled w scrut_ty) res_ty alts -- | Build a strict application (case e2 of x -> e1 x) mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr mkStrictApp fun arg (Scaled w arg_ty) res_ty - = Case arg arg_id res_ty [Alt DEFAULT [] (App fun (Var arg_id))] + = Case arg arg_id res_ty [Alt DEFAULT NoFreq [] (App fun (Var arg_id))] -- mkDefaultCase looks attractive here, and would be sound. -- But it uses (exprType alt_rhs) to compute the result type, -- whereas here we already know that the result type is res_ty @@ -248,8 +248,8 @@ mkIfThenElse :: CoreExpr -- ^ guard mkIfThenElse guard then_expr else_expr -- Not going to be refining, so okay to take the type of the "then" clause = mkWildCase guard (linear boolTy) (exprType then_expr) - [ Alt (DataAlt falseDataCon) [] else_expr, -- Increasing order of tag! - Alt (DataAlt trueDataCon) [] then_expr ] + [ Alt (DataAlt falseDataCon) NoFreq [] else_expr, -- Increasing order of tag! + Alt (DataAlt trueDataCon) NoFreq [] then_expr ] castBottomExpr :: CoreExpr -> Type -> CoreExpr -- (castBottomExpr e ty), assuming that 'e' diverges, @@ -560,7 +560,7 @@ mkSmallTupleSelector vars the_var scrut_var scrut mkSmallTupleSelector1 vars the_var scrut_var scrut = assert (notNull vars) $ Case scrut scrut_var (idType the_var) - [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)] + [Alt (DataAlt (tupleDataCon Boxed (length vars))) NoFreq vars (Var the_var)] -- | A generalization of 'mkTupleSelector', allowing the body -- of the case to be an arbitrary expression. @@ -614,7 +614,7 @@ mkSmallTupleCase [var] body _scrut_var scrut mkSmallTupleCase vars body scrut_var scrut -- One branch no refinement? = Case scrut scrut_var (exprType body) - [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] + [Alt (DataAlt (tupleDataCon Boxed (length vars))) NoFreq vars body] {- ************************************************************************ diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs index 9cff1d33a1..cc5bce1f52 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -348,11 +348,11 @@ instance TrieMap AltMap where instance Eq (DeBruijn CoreAlt) where D env1 a1 == D env2 a2 = go a1 a2 where - go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2) + go (Alt DEFAULT _ _ rhs1) (Alt DEFAULT _ _ rhs2) = D env1 rhs1 == D env2 rhs2 - go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2) + go (Alt (LitAlt lit1) _ _ rhs1) (Alt (LitAlt lit2) _ _ rhs2) = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 - go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2) + go (Alt (DataAlt dc1) _ bs1 rhs1) (Alt (DataAlt dc2) _ bs2 rhs2) = dc1 == dc2 && D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 go _ _ = False @@ -370,17 +370,17 @@ ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) , am_lit = mapTM (filterTM f) alit } lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a -lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) -lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) -lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc +lkA env (Alt DEFAULT _ _ rhs) = am_deflt >.> lkG (D env rhs) +lkA env (Alt (LitAlt lit) _ _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) +lkA env (Alt (DataAlt dc) _ bs rhs) = am_data >.> lkDNamed dc >=> lkG (D (extendCMEs env bs) rhs) xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a -xtA env (Alt DEFAULT _ rhs) f m = +xtA env (Alt DEFAULT _ _ rhs) f m = m { am_deflt = am_deflt m |> xtG (D env rhs) f } -xtA env (Alt (LitAlt l) _ rhs) f m = +xtA env (Alt (LitAlt l) _ _ rhs) f m = m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } -xtA env (Alt (DataAlt d) bs rhs) f m = +xtA env (Alt (DataAlt d) _ bs rhs) f m = m { am_data = am_data m |> xtDNamed d |>> xtG (D (extendCMEs env bs) rhs) f } diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index f25d04e0ed..815c4935ec 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -1058,7 +1058,7 @@ arityType env (Case scrut bndr _ alts) = takeWhileOneShot alts_type -- evaluation of the scrutinee in where env' = delInScope env bndr - arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs + arity_type_alt (Alt _con _freq bndrs rhs) = arityType (delInScopeList env' bndrs) rhs alts_type = foldr1 andArityType (map arity_type_alt alts) arityType env (Let (NonRec j rhs) body) @@ -1503,7 +1503,7 @@ etaInfoApp in_scope expr eis (subst1, b1) = Core.substBndr subst b alts' = map subst_alt alts ty' = etaInfoAppTy (Core.substTy subst ty) eis - subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) + subst_alt (Alt con freq bs rhs) = Alt con freq bs' (go subst2 rhs eis) where (subst2,bs') = Core.substBndrs subst1 bs diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 6b5a12e9f1..172f8cd609 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -672,15 +672,15 @@ cseCase env scrut bndr ty alts arg_tys = tyConAppArgs (idType bndr3) -- See Note [CSE for case alternatives] - cse_alt (Alt (DataAlt con) args rhs) - = Alt (DataAlt con) args' (tryForCSE new_env rhs) + cse_alt (Alt (DataAlt con) freq args rhs) + = Alt (DataAlt con) freq args' (tryForCSE new_env rhs) where (env', args') = addBinders alt_env args new_env = extendCSEnv env' con_expr con_target con_expr = mkAltExpr (DataAlt con) args' arg_tys - cse_alt (Alt con args rhs) - = Alt con args' (tryForCSE env' rhs) + cse_alt (Alt con freq args rhs) + = Alt con freq args' (tryForCSE env' rhs) where (env', args') = addBinders alt_env args @@ -688,11 +688,11 @@ combineAlts :: CSEnv -> [OutAlt] -> [OutAlt] -- See Note [Combine case alternatives] combineAlts env alts | (Just alt1, rest_alts) <- find_bndr_free_alt alts - , Alt _ bndrs1 rhs1 <- alt1 + , Alt _ _ bndrs1 rhs1 <- alt1 , let filtered_alts = filterOut (identical_alt rhs1) rest_alts , not (equalLength rest_alts filtered_alts) = assertPpr (null bndrs1) (ppr alts) $ - Alt DEFAULT [] rhs1 : filtered_alts + Alt DEFAULT NoFreq [] rhs1 : filtered_alts | otherwise = alts @@ -704,12 +704,12 @@ combineAlts env alts -- See Note [Combine case alts: awkward corner] find_bndr_free_alt [] = (Nothing, []) - find_bndr_free_alt (alt@(Alt _ bndrs _) : alts) + find_bndr_free_alt (alt@(Alt _ _ bndrs _) : alts) | null bndrs = (Just alt, alts) | otherwise = case find_bndr_free_alt alts of (mb_bf, alts) -> (mb_bf, alt:alts) - identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs + identical_alt rhs1 (Alt _ _ _ rhs) = eqExpr in_scope rhs1 rhs -- Even if this alt has binders, they will have been cloned -- If any of these binders are mentioned in 'rhs', then -- 'rhs' won't compare equal to 'rhs1' (which is from an diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index d8d9749941..7a52e0c499 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -525,8 +525,8 @@ callArityAnal arity int (Case scrut bndr ty alts) (final_ae, Case scrut' bndr ty alts') where (alt_aes, alts') = unzip $ map go alts - go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity (int `delVarSetList` (bndr:bndrs)) e - in (ae, Alt dc bndrs e') + go (Alt dc f bndrs e) = let (ae, e') = callArityAnal arity (int `delVarSetList` (bndr:bndrs)) e + in (ae, Alt dc f bndrs e') alt_ae = lubRess alt_aes (scrut_ae, scrut') = callArityAnal 0 int scrut final_ae = scrut_ae `both` alt_ae diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs index 3c47da66af..d20b41d91b 100644 --- a/compiler/GHC/Core/Opt/CallerCC.hs +++ b/compiler/GHC/Core/Opt/CallerCC.hs @@ -94,7 +94,7 @@ doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs doExpr env (Case scrut b ty alts) = Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts where - doAlt (Alt con bs rhs) = Alt con bs <$> doExpr env rhs + doAlt (Alt con freq bs rhs) = Alt con freq bs <$> doExpr env rhs doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co doExpr env (Tick t e) = Tick t <$> doExpr env e doExpr _env e@(Type _) = pure e diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index e4d04c3548..56fba28178 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1084,8 +1084,8 @@ litEq is_eq = msum do_lit_eq platform lit expr = do guard (not (litIsLifted lit)) return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy - [ Alt DEFAULT [] val_if_neq - , Alt (LitAlt lit) [] val_if_eq]) + [ Alt DEFAULT NoFreq [] val_if_neq + , Alt (LitAlt lit) NoFreq [] val_if_eq]) where val_if_eq | is_eq = trueValInt platform | otherwise = falseValInt platform @@ -1102,8 +1102,6 @@ boundsCmp op = do [a, b] <- getArgs liftMaybe $ mkRuleFn platform op a b -data Comparison = Gt | Ge | Lt | Le - mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt platform diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index f3ae2c0b43..2247751990 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -204,8 +204,8 @@ cprAnalAlt -> CprType -- ^ CPR type of the scrutinee -> Alt Var -- ^ current alternative -> (CprType, Alt Var) -cprAnalAlt env scrut_ty (Alt con bndrs rhs) - = (rhs_ty, Alt con bndrs rhs') +cprAnalAlt env scrut_ty (Alt con freq bndrs rhs) + = (rhs_ty, Alt con freq bndrs rhs') where env_alt | DataAlt dc <- con diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 5f209701a9..6f03fbea96 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -419,10 +419,10 @@ dmdAnal' env dmd (Lam var body) in WithDmdType new_dmd_type (Lam var' body') -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) +dmdAnal' env dmd (Case scrut case_bndr ty [Alt con freq bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type. - | is_single_data_alt alt + | is_single_data_alt con = let WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs WithDmdType alt_ty1 dmds = findBndrsDmds env rhs_ty bndrs @@ -434,7 +434,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- FORCE the result, otherwise thunks will end up retaining the -- whole DmdEnv !(!bndrs', !scrut_sd) - | DataAlt _ <- alt + | DataAlt _ <- con , id_dmds <- addCaseBndrDmd case_bndr_sd dmds -- See Note [Demand on scrutinee of a product case] = let !new_info = setBndrsDemandInfo bndrs id_dmds @@ -463,7 +463,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs']) + WithDmdType res_ty (Case scrut' case_bndr' ty [Alt con freq bndrs' rhs']) where is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc is_single_data_alt _ = True @@ -545,7 +545,7 @@ forcesRealWorld fam_envs ty = False dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var) -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) +dmdAnalSumAlt env dmd case_bndr (Alt con freq bndrs rhs) | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr @@ -553,7 +553,7 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) id_dmds = addCaseBndrDmd case_bndr_sd dmds -- Do not put a thunk into the Alt !new_ids = setBndrsDemandInfo bndrs id_dmds - = WithDmdType alt_ty (Alt con new_ids rhs') + = WithDmdType alt_ty (Alt con freq new_ids rhs') {- Note [Analysing with absent demand] diff --git a/compiler/GHC/Core/Opt/ExecFreq.hs b/compiler/GHC/Core/Opt/ExecFreq.hs new file mode 100644 index 0000000000..6bd65bf72d --- /dev/null +++ b/compiler/GHC/Core/Opt/ExecFreq.hs @@ -0,0 +1,482 @@ +-- | Analyses concerned with how often some part of an expression is executed. +-- +-- Currently, we only estimate relative frequency of case alternatives, but we +-- may estimate static profiles for whole functions in the future (taking into +-- account loops, etc.). The basic ideas are borrowed from the imperative world: +-- +-- [1] Branch prediction for free. Ball and Larus, 1993. +-- https://dl.acm.org/doi/abs/10.1145/173262.155119 +-- +-- [2] Static branch frequency and program profile analysis. Wu and Larus, 1994. +-- https://dl.acm.org/doi/10.1145/192724.192725 +-- +-- See Note [Estimating CoreAlt frequencies] for implementation details. +-- +module GHC.Core.Opt.ExecFreq + ( estimateAltFreqs + ) +where + +import GHC.Prelude +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Ppr +import GHC.Types.Basic +import GHC.Types.Literal +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Builtin.PrimOps +import GHC.Utils.Misc +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Utils.Trace +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List (sortOn, groupBy, nub) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty + +{- Note [Estimating CoreAlt frequencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very useful for a compiler to know when one case alternative is taken +much more often than another. For example, consider + + sum n = case n of + 0 -> 0 :: Int + _ -> n + sum (n-1) + +Here, for the vast majority of inputs, control flow enters the second +alternative, because + + 1. Most Ints aren't equal to 0 + 2. The second alternative contains a recursive call, indicating a loop of some + sort. Most loops loop more often than once, hence it's a plausible estimate + that we will not yet exit it. + +Equipped with that knowledge, the compiler can optimise 'sum' favoring +transformations that improve the second branch, even if that means the first +branch gets a bit slower. Some examples: + + * The Simplifier could decide not to inline in the cold branch, having more + code size to spend inlining in the second branch. + * The first branch may need some value boxed, but the second one doesn't. It + may be more efficient to unbox the value and re-allocate the box in the + first branch. + * Similarly, we could give 'sum' the CPR property, thereby unboxing its result + and destroying the sharing of the (then floated out) 0 CAF. + * We may float out a binding from the second alternative, even if that means + more allocation if we take the first alternative + * (Feel free to add more...) + +How do we know which alternatives are hotter/colder than others? + +This problem has long been solved in the imperative world, where there are +always just 2 alternatives in each branch decision. We'll build on + + [1] Branch prediction for free. Ball and Larus, 1993. + https://dl.acm.org/doi/abs/10.1145/173262.155119 + [2] Static branch frequency and program profile analysis. Wu and Larus, 1994. + https://dl.acm.org/doi/10.1145/192724.192725 + [3] Corpus-based static branch prediction. Calder et al., 1995. + https://dl.acm.org/doi/10.1145/223428.207118 + +[1] comes up with a set of useful branch heuristics and measures their +effectiveness. [2] builds on the branch heuristics of [1] and contributes how to +fuse evidence from different heuristics (implemented as 'fuseHeuristic'). + +We implement a couple of different Heuristics, inspired by [1]: + + 1. Opcode Heuristic (OH) captures intuition like "most Ints aren't equal to a + single constant", but goes a bit beyond that. See 'opcodeHeuristic'. + 2. Loop Branch Heuristic (LBH, see 'loopBranchHeuristic') captures the + intuition that recursive alts are taken more often than non-recursive ones. + 3. Call Heuristic (CH) says that alts with external calls are rather cold. + See 'callHeuristic'. + 4. Store Heuristic (SH) says that alts with stores are cold. We extend this to + general side-effects. See 'storeHeuristic'. + 5. Return Heuristic (RH) says that alts that quickly return are cold. We + interpret this to mean that paths are cold when they don't jump to a + (shared) join point. See 'returnHeuristic'. + +It's a bit questionable if and how (3) to (5) apply to functional programs. +They might give false indications if regarded in isolation, but in concert with +other heuristics, they might be worth it. The occurrence info that is necessary +to support (3) to (5) is a bit complicated to characterise, so they are +deactivated for now. + +Current weights of how much we can trust each individual heuristic are just +rough guesses based on the numbers reported in [1] and [2]. We should eventually +derive these weights by profiling information, training our machine learning +algorithm, so to speak. That is exactly what [3] does. +-} + +{- +************************************************************************ +* * + Env+Usage: Gathering occurrence info +* * +************************************************************************ +-} + +data Env = E + { e_level :: !Int + , e_rec_bndrs :: !(IdEnv Int) + } + +emptyEnv :: Env +emptyEnv = E { e_level = 0, e_rec_bndrs = emptyVarEnv } + +delBndrEnv :: Env -> Id -> Env +delBndrEnv env bndr = delBndrsEnv env [bndr] + +delBndrsEnv :: Env -> [Id] -> Env +delBndrsEnv env bndrs + = env { e_rec_bndrs = delVarEnvList (e_rec_bndrs env) bndrs } + +enterRec :: Env -> [Id] -> Env +enterRec env bndrs + = env { e_level = e_level env + 1 + , e_rec_bndrs = extendVarEnvList (e_rec_bndrs env) pairs } + where + pairs = zip bndrs (repeat (e_level env)) + +data Usage = U + { u_uses :: !IdSet + , u_lvls :: !(IntMap IdSet) + , u_exit_path :: !Bool + , u_ext_calls :: !Bool + , u_side_effect :: !Bool + } + +instance Outputable Usage where + ppr (U uses lvls exit_path ext_calls side_effect) = char 'U' <> braces (fcat + [ text "uses=", ppr uses + , comma, text "lvls=", ppr lvls + , if exit_path then comma <> text "exit_path" else empty + , if ext_calls then comma <> text "ext_calls" else empty + , if side_effect then comma <> text "side_effect" else empty + ]) + +emptyUsage :: Usage +emptyUsage = U + { u_uses = emptyVarSet + , u_lvls = IntMap.empty + , u_exit_path = False + , u_ext_calls = False + , u_side_effect = False } + +singleUsage :: Env -> Id -> Usage +singleUsage env b + | isGlobalId b, idArity b > 0, not $ isPrimOpId b, not $ isDataConWorkId b, not $ isDataConWrapId b + = emptyUsage { u_ext_calls = True } + | Just op <- isPrimOpId_maybe b, not $ primOpOkForSideEffects op + = emptyUsage { u_side_effect = True } + | isLocalId b + = emptyUsage { u_lvls = lvls, u_uses = unitVarSet b, u_exit_path = not (isJoinId b) && idArity b == 0 } + | otherwise = emptyUsage + where + lvls = case lookupVarEnv (e_rec_bndrs env) b of + Just lvl -> IntMap.singleton lvl (unitVarSet b) + Nothing -> IntMap.empty + +leaveScope :: Usage -> [Id] -> Usage +leaveScope u bndrs + = u { u_uses = delVarSetList (u_uses u) bndrs } + +leaveRec :: Int -> Usage -> [Id] -> Usage +leaveRec lvl u bndrs + = u { u_uses = delVarSetList (u_uses u) bndrs + , u_lvls = IntMap.alter f lvl (u_lvls u) } + where + f Nothing = Nothing + f (Just set) + | let set' = delVarSetList set bndrs + , not $ isEmptyVarSet set' + = Just set' + | otherwise + = Nothing + +lubUsages :: [Usage] -> Usage +lubUsages = foldl' f emptyUsage{u_exit_path = True} + where + f u1 u2 = U { u_uses = unionVarSet (u_uses u1) (u_uses u2) + , u_lvls = IntMap.unionWith unionVarSet (u_lvls u1) (u_lvls u2) + , u_exit_path = u_exit_path u1 && u_exit_path u2 + , u_ext_calls = u_ext_calls u1 || u_ext_calls u2 + , u_side_effect = u_side_effect u1 || u_side_effect u2 } + +thenUsage :: Usage -> Usage -> Usage +thenUsage u1 u2 = U { u_uses = unionVarSet (u_uses u1) (u_uses u2) + , u_lvls = IntMap.unionWith unionVarSet (u_lvls u1) (u_lvls u2) + , u_exit_path = u_exit_path u2 -- IMPORTANT difference to lub + , u_ext_calls = u_ext_calls u1 || u_ext_calls u2 + , u_side_effect = u_side_effect u1 || u_side_effect u2 } + +{- +************************************************************************ +* * + Main analysis traversal +* * +************************************************************************ +-} + +-- | See Note [Estimating CoreAlt frequencies]. +estimateAltFreqs :: CoreProgram -> CoreProgram +estimateAltFreqs = go emptyEnv + where + go _ [] = [] + go env (b:bs) = b' : go env' bs + where + (env', _, b') = analBind env b + +analBind :: Env -> CoreBind -> (Env, Usage, CoreBind) +analBind env (NonRec b rhs) = (delBndrEnv env b, usg, NonRec b rhs') + where + (usg, rhs') = analExpr env rhs +analBind env (Rec pairs) = (env', usg', Rec pairs') + where + (bs, rhss) = unzip pairs + env' = enterRec env bs + (usgs, rhss') = mapAndUnzip (analExpr env') rhss + pairs' = zip bs rhss' + usg' = lubUsages usgs + +analExpr :: Env -> CoreExpr -> (Usage, CoreExpr) +analExpr env e = case e of + Coercion{} -> (emptyUsage, e) + Type{} -> (emptyUsage, e) + Lit{} -> (emptyUsage, e) + (Var v) -> (singleUsage env v, e) + Cast e co | (usg, e') <- analExpr env e -> (usg, Cast e' co) + Tick t e | (usg, e') <- analExpr env e -> (usg, Tick t e') + Lam b e | (usg, e') <- analExpr (delBndrEnv env b) e -> (leaveScope usg [b], Lam b e') + App f a + | (usg_f, f') <- analExpr env f + , (usg_a, a') <- analExpr env a + -> (usg_a `thenUsage` usg_f, App f' a') + Let bind e + | (env', usg_bs, bind') <- analBind env bind + , (usg_e, e') <- analExpr env' e + , let leave = case bind of Rec{} -> leaveRec (e_level env); _ -> leaveScope + -> (leave (usg_bs `thenUsage` usg_e) (bindersOf bind), Let bind' e') + Case scrut b ty alts + | (usg_scrut, scrut') <- analExpr env scrut + , let usg_w_alts = map (analAlt (delBndrEnv env b)) alts + , (usg_alts, alts') <- applyHeuristic heuristic scrut usg_w_alts + -> (leaveScope (usg_scrut `thenUsage` lubUsages usg_alts) [b], Case scrut' b ty alts') + where + -- heuristic = traceHeuristic "combined" $ fuseHeuristics $ NonEmpty.fromList + heuristic = fuseHeuristics $ NonEmpty.fromList + [ loopBranchHeuristic + , opcodeHeuristic + , ignoreHeuristic $ traceHeuristic "CH" $ callHeuristic + , ignoreHeuristic $ traceHeuristic "SH" $ storeHeuristic + , ignoreHeuristic $ traceHeuristic "RH" $ returnHeuristic + ] + +analAlt :: Env -> CoreAlt -> (Usage, CoreAlt) +analAlt env (Alt con freq bs rhs) = (leaveScope usg bs, Alt con freq bs rhs') + where + (usg, rhs') = analExpr (delBndrsEnv env bs) rhs + +{- +************************************************************************ +* * + Branch heuristics +* * +************************************************************************ +-} + +-- | A Branch/Alt prediction heuristic. See Note [Estimating CoreAlt frequencies]. +type Heuristic = CoreExpr -> [(AltCon, [Var], Usage)] -> Maybe [Freq] + +-- | Associative. So 'Heuristic' is a Semigroup via this operation. +-- This operation is Dempster's rule of combination for the very narrow use case +-- of ours, where all masses of non-singleton sets are 0. +-- +-- See Note [Estimating CoreAlt frequencies]. +fuseHeuristic :: Heuristic -> Heuristic -> Heuristic +fuseHeuristic a b scrut alts = a scrut alts <+> b scrut alts + where + f1 <+> Nothing = f1 + Nothing <+> f2 = f2 + Just f1 <+> Just f2 = Just $! normaliseFreqs joint -- Dampster's rule of combination + where + joint = zipWithEqual "fuseHeuristic" (*) f1 f2 + +fuseHeuristics :: NonEmpty Heuristic -> Heuristic +fuseHeuristics = foldr1 fuseHeuristic + +traceHeuristic :: String -> Heuristic -> Heuristic +traceHeuristic descr heur scrut alts = pprTrace descr (pprCoreExpr scrut $$ ppr alts $$ ppr freqs) freqs + where + freqs = heur scrut alts +_ = traceHeuristic -- suppress unused warning + +ignoreHeuristic :: Heuristic -> Heuristic +ignoreHeuristic _heur _scrut _alts = Nothing + +applyHeuristic :: Heuristic -> CoreExpr -> [(Usage, CoreAlt)] -> ([Usage], [CoreAlt]) +applyHeuristic heur scrut usg_w_alts = (usgs, alts') + where + heur_alts = [ (con, bs, usg) | (usg, Alt con _ bs _) <- usg_w_alts ] + freqs = heur scrut heur_alts `orElse` uniformFreqs (length alts) + (usgs, alts) = unzip usg_w_alts + alts' = zipWith (\(Alt con _ bs rhs) freq -> Alt con freq bs rhs) alts freqs + +-- | Returns 'True' if the given predicate is neither all 'True' or all 'False' +-- on the elements of the list. +discriminates :: (a -> Bool) -> [a] -> Bool +discriminates p xs + | [_all_true_or_false] <- nub (map p xs) = False -- NB: we shortcircuit on the 2nd distinct element! + | otherwise = True + +-- | This is the Loop Branch Heuristic from [1] and [2]. +-- +-- "Predict as taken an edge back to a loop’s head. Predict as not taken an +-- edge exiting a loop." +-- +-- Our back edges are calls to recursive functions, the nesting levels of which +-- we track in 'u_lvls'. +loopBranchHeuristic :: Heuristic +loopBranchHeuristic _scrut alts + | applies = Just $! freqs + | otherwise = Nothing + where + max_back_lvl usg = case IntMap.lookupMax (u_lvls usg) of + Nothing -> -1 -- lower than all other levels + Just (lvl, _) -> lvl + max_back_lvls = map (\(con, _, usg) -> (max_back_lvl usg, con)) alts + has_back_edge = (>= 0) . fst + applies = discriminates has_back_edge max_back_lvls + sorted_back_lvls = sortOn fst max_back_lvls + lvl_batches = groupBy (\a b -> fst a == fst b) sorted_back_lvls + lvl_factor = 4 -- Factor by which we favor higher-level back edges + batches_w_counts = zip lvl_batches [ lvl_factor^i | i <- [0::Int, 1 ..] ] + -- Example: + -- * alt A has back_lvl -1 (e.g., no back edge) + -- * alts B,D have back_lvl 2 (e.g., continue outermost loops) + -- * alt C has back_lvl 14 (e.g., continues the innermost loop) + -- Then we'd get lvl_batches of [(-1, [A]), (2, [B,D]), (14, [C])] + -- and we'd get assoc counts of [ 1 , 4, 16 ], + -- so increasing with lvl_factor 4. + -- And then we simply re-align with the original alts and normalise to get + -- alts [(A,_,_), (B,_,_), (C,_,_), (D,_,_) ] + -- freqs [ 0.4 , 0.16 , 0.64 , 0.16 ] + total_count = sum $ map (\(grp, c) -> c * length grp) batches_w_counts + cons_freqs = [ (con, Freq (fromIntegral c / fromIntegral total_count)) + | (grp, c) <- batches_w_counts + , (_, con) <- grp ] + freqs = [ expectJust "con not present" $ lookup con cons_freqs | (con, _, _) <- alts ] + +-- | @usgHeuristic p yes no@ is a 'Heuristic' that applies whenever `p` is a +-- discriminating predicate on the case alternatives, weighing alternatives +-- that satisfy `p` with integer weights `yes` and those that don't with `no`. +usgHeuristic :: (Usage -> Bool) -> Int -> Int -> Heuristic +usgHeuristic p yes no _scrut alts + | applies = Just $! freqs + | otherwise = Nothing + where + applies = discriminates (\(_, _, usg) -> p usg) alts + freqs = absToRelFreqs [ if p usg then yes else no | (_, _, usg) <- alts ] + +-- | This is the Return Heuristic from [1] and [2]. +-- +-- "Predict a successor that contains a store instruction and does not +-- post-dominate will not be taken." +-- +-- We interpret "store" as primops with side-effects here. Also we don't only +-- look into direct successors, but the whole alternative +-- (for practical reasons). It doesn't work well, as exit paths tend to have no +-- side-effects and thus will win from this heuristic. +returnHeuristic :: Heuristic +returnHeuristic = usgHeuristic u_exit_path 1 4 + +-- | This is the Call Heuristic from [1] and [2]. +-- +-- "Predict a successor that contains a store instruction and does not +-- post-dominate will not be taken." +-- +-- We interpret "store" as primops with side-effects here. Also we don't only +-- look into direct successors, but the whole alternative +-- (for practical reasons). It doesn't work well, as exit paths tend to have no +-- side-effects and thus will win from this heuristic. +callHeuristic :: Heuristic +callHeuristic = usgHeuristic u_ext_calls 1 4 + +-- | This is the Store Heuristic from [1] and [2]. +-- +-- "Predict a successor that contains a store instruction and does not +-- post-dominate will not be taken." +-- +-- We interpret "store" as primops with side-effects here. Also we don't only +-- look into direct successors, but the whole alternative +-- (for practical reasons). It doesn't work well, as exit paths tend to have no +-- side-effects and thus will win from this heuristic. +storeHeuristic :: Heuristic +storeHeuristic = usgHeuristic u_side_effect 1 4 + +predictSpecificAlt :: (AltCon -> Bool) -> [(AltCon, [Var], Usage)] -> [Freq] +predictSpecificAlt p = absToRelFreqs . snd . foldr go (False, []) + where + high_freq = 5 + low_freq = 1 + go (con, _, _) (found_it, abs_freqs) = case con of + DEFAULT | not found_it -> (True, high_freq:abs_freqs) + -- DEFAULT always comes first in alts if it exists + -- Thus, it will be the last thing `go` encounters. + -- If we haven't found a matching AltCon so far, we pick DEFAULT + _ | p con -> (True, high_freq:abs_freqs) + | otherwise -> (found_it, low_freq:abs_freqs) + +predictZero, predictOne, predictDefault :: [(AltCon, [Var], Usage)] -> [Freq] + +predictZero = predictSpecificAlt p + where + p (LitAlt l) = isZeroLit l + p _ = False + +predictOne = predictSpecificAlt p + where + p (LitAlt l) = isOneLit l + p _ = False + +predictDefault = predictSpecificAlt p + where + p DEFAULT = True + p _ = False + +-- | This is the Opcode Heuristic from [1] and [2]. +-- +-- "Predict that a comparison of an integer [for us: general literal] for less +-- than zero, less than or equal to zero, or equal to a constant, will fail." +-- +-- We extend the heuristic slightly to deal with multiple literal alts, in which +-- we predict the DEFAULT alt. Predicting the `< 0` and `<= 0` cases as False +-- is a choice we might want to revisit; the original paper did it based on the +-- use of negative error codes that are prevalent in C. +opcodeHeuristic :: Heuristic +opcodeHeuristic scrut alts + | not $ any lit_alt alts = Nothing + | [_, _] <- alts = case putLitRight <$> isComparisonApp_maybe scrut of + -- putLitRight arranges it such that the Literal is the right operand + Just (cmp, _, Lit r_lit) + | isZeroLit r_lit -> Just $! case cmp of + Lt -> predictZero alts + Le -> predictZero alts + Eq -> predictZero alts + Gt -> predictOne alts + Ge -> predictOne alts + Ne -> predictOne alts + | Eq <- cmp -> Just $! predictZero alts + | Ne <- cmp -> Just $! predictOne alts + _ -> Just $! predictDefault alts + | otherwise = Just $! predictDefault alts + where + lit_alt (LitAlt{}, _, _) = True + lit_alt _ = False + +putLitRight :: (Comparison, CoreExpr, CoreExpr) -> (Comparison, CoreExpr, CoreExpr) +putLitRight (cmp, l@Lit{}, r) = (flipComparison cmp, r, l) +putLitRight orig = orig diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index 7da0a68989..d22cfa795d 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -81,7 +81,7 @@ exitifyProgram binds = map goTopLvl binds = Case (go in_scope scrut) bndr ty (map go_alt alts) where in_scope1 = in_scope `extendInScopeSet` bndr - go_alt (Alt dc pats rhs) = Alt dc pats (go in_scope' rhs) + go_alt (Alt dc freq pats rhs) = Alt dc freq pats (go in_scope' rhs) where in_scope' = in_scope1 `extendInScopeSetList` pats go in_scope (Let (NonRec bndr rhs) body) @@ -152,9 +152,9 @@ exitifyRec in_scope pairs -- Case right hand sides are in tail-call position go captured (_, AnnCase scrut bndr ty alts) = do - alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do + alts' <- forM alts $ \(AnnAlt dc freq pats rhs) -> do rhs' <- go (captured ++ [bndr] ++ pats) rhs - return (Alt dc pats rhs') + return (Alt dc freq pats rhs') return $ Case (deAnnotate scrut) bndr ty alts' go captured (_, AnnLet ann_bind body) diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index 6e4b724310..8f188f9935 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -446,7 +446,7 @@ bindings are: -} -fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) +fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con _freq alt_bndrs rhs]) | isUnliftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) -- See Note [Floating primops] @@ -485,12 +485,12 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts all_alts_fvs = unionDVarSets alts_fvs - alt_fvs (AnnAlt _con args rhs) + alt_fvs (AnnAlt _con _float args rhs) = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt - fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs) + fi_alt to_drop (AnnAlt con freq args rhs) = Alt con freq args (fiExpr platform to_drop rhs) ------------------ fiBind :: Platform diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index fbed53fbf3..7fa2df8ba1 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -467,7 +467,7 @@ floatExpr (Let bind body) floatExpr (Case scrut (TB case_bndr case_spec) ty alts) = case case_spec of FloatMe dest_lvl -- Case expression moves - | [Alt con@(DataAlt {}) bndrs rhs] <- alts + | [Alt con@(DataAlt {}) _freq bndrs rhs] <- alts -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') -> case floatExpr rhs of { (fsb, fdb, rhs') -> let @@ -484,9 +484,9 @@ floatExpr (Case scrut (TB case_bndr case_spec) ty alts) (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') }} where - float_alt bind_lvl (Alt con bs rhs) + float_alt bind_lvl (Alt con freq bs rhs) = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, Alt con [b | TB b _ <- bs] rhs') } + (fs, rhs_floats, Alt con freq [b | TB b _ <- bs] rhs') } floatRhs :: CoreBndr -> LevelledExpr diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs index 3c9eb5c3d0..522464eaa9 100644 --- a/compiler/GHC/Core/Opt/LiberateCase.hs +++ b/compiler/GHC/Core/Opt/LiberateCase.hs @@ -254,7 +254,7 @@ libCase env (Case scrut bndr ty alts) mk_alt_env _ = env libCaseAlt :: LibCaseEnv -> Alt CoreBndr -> Alt CoreBndr -libCaseAlt env (Alt con args rhs) = Alt con args (libCase (addBinders env args) rhs) +libCaseAlt env (Alt con freq args rhs) = Alt con freq args (libCase (addBinders env args) rhs) {- Ids diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 7df9ead69f..fdba047480 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -2301,12 +2301,12 @@ occAnalLamOrRhs env binders body occAnalAlt :: OccEnv -> CoreAlt -> WithUsageDetails (Alt IdWithOccInfo) -occAnalAlt !env (Alt con bndrs rhs) +occAnalAlt !env (Alt con freq bndrs rhs) = let (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs in -- See Note [Binders in case alternatives] - WithUsageDetails alt_usg (Alt con tagged_bndrs rhs1) + WithUsageDetails alt_usg (Alt con freq tagged_bndrs rhs1) {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 2d69e8eb04..054188e396 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -111,7 +111,7 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Tickish ( tickishIsCode ) import GHC.Types.Unique.Supply import GHC.Types.Unique.DFM -import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) +import GHC.Types.Basic import GHC.Builtin.Types import GHC.Builtin.Names ( runRWKey ) @@ -494,7 +494,7 @@ lvlCase :: LevelEnv -- Level of in-scope names/tyvars -> LvlM LevelledExpr -- Result expression lvlCase env scrut_fvs scrut' case_bndr ty alts -- See Note [Floating single-alternative cases] - | [AnnAlt con@(DataAlt {}) bs body] <- alts + | [AnnAlt con@(DataAlt {}) freq bs body] <- alts , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] , not (isTopLvl dest_lvl) -- Can't have top-level cases , not (floatTopLvlOnly env) -- Can float anywhere @@ -504,7 +504,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut' ; body' <- lvlMFE rhs_env True body - ; let alt' = Alt con (map (stayPut dest_lvl) bs') body' + ; let alt' = Alt con freq (map (stayPut dest_lvl) bs') body' ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) } | otherwise -- Stays put @@ -519,9 +519,9 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts dest_lvl = maxFvLevel (const True) env scrut_fvs -- Don't abstract over type variables, hence const True - lvl_alt alts_env (AnnAlt con bs rhs) + lvl_alt alts_env (AnnAlt con freq bs rhs) = do { rhs' <- lvlMFE new_env True rhs - ; return (Alt con bs' rhs') } + ; return (Alt con freq bs' rhs') } where (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs @@ -704,13 +704,13 @@ lvlMFE env strict_ctxt ann_expr ; let l1r = incMinorLvlFrom rhs_env float_rhs = mkLams abs_vars_w_lvls $ Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])] + [Alt DEFAULT NoFreq [] (mkConApp dc [Var ubx_bndr])] ; var <- newLvlVar float_rhs Nothing is_mk_static ; let l1u = incMinorLvlFrom env use_expr = Case (mkVarApps (Var var) abs_vars) (stayPut l1u bx_bndr) expr_ty - [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] + [Alt (DataAlt dc) NoFreq [stayPut l1u ubx_bndr] (Var ubx_bndr)] ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) use_expr) } diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 11b0b50036..7517fc9962 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1375,7 +1375,7 @@ simplTick env tickish expr cont tickScrut e = foldr mkTick e ticks -- Alternatives get annotated with all ticks that scope in some way, -- but we don't want to count entries. - tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) + tickAlt (Alt c f bs e) = Alt c f bs (foldr mkTick e ts_scope) ts_scope = map mkNoCount $ filter (not . (`tickishScopesLike` NoScope)) ticks @@ -2755,7 +2755,7 @@ rebuildCase env scrut case_bndr alts cont = do { tick (KnownBranch case_bndr) ; case findAlt (LitAlt lit) alts of Nothing -> missingAlt env case_bndr alts cont - Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } + Just (Alt _ _ bs rhs) -> simple_rhs env [] scrut bs rhs } | Just (in_scope', wfloats, con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut @@ -2771,8 +2771,8 @@ rebuildCase env scrut case_bndr alts cont `mkApps` other_args ; case findAlt (DataAlt con) alts of Nothing -> missingAlt env0 case_bndr alts cont - Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs - Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args + Just (Alt DEFAULT _ bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs + Just (Alt _ _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args other_args case_bndr bs rhs cont } where @@ -2820,7 +2820,7 @@ rebuildCase env scrut case_bndr alts cont -- 2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont +rebuildCase env scrut case_bndr alts@[Alt _ _ bndrs rhs] cont -- See if we can get rid of the case altogether -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, @@ -3054,7 +3054,7 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv -> OutExpr -> InId -> OutId -> [InAlt] -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] +improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _ _] | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) = do { case_bndr2 <- newId (fsLit "nt") Many ty2 ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing @@ -3075,21 +3075,21 @@ simplAlt :: SimplEnv -> InAlt -> SimplM OutAlt -simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) +simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT freq bndrs rhs) = assert (null bndrs) $ do { let env' = addBinderUnfolding env case_bndr' (mkOtherCon imposs_deflt_cons) -- Record the constructors that the case-binder *can't* be. ; rhs' <- simplExprC env' rhs cont' - ; return (Alt DEFAULT [] rhs') } + ; return (Alt DEFAULT freq [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs) +simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) freq bndrs rhs) = assert (null bndrs) $ do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) ; rhs' <- simplExprC env' rhs cont' - ; return (Alt (LitAlt lit) [] rhs') } + ; return (Alt (LitAlt lit) freq [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) +simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) freq vs rhs) = do { -- See Note [Adding evaluatedness info to pattern-bound variables] let vs_with_evals = addEvals scrut' con vs ; (env', vs') <- simplLamBndrs env vs_with_evals @@ -3101,7 +3101,7 @@ simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app ; rhs' <- simplExprC env'' rhs cont' - ; return (Alt (DataAlt con) vs' rhs') } + ; return (Alt (DataAlt con) freq vs' rhs') } {- Note [Adding evaluatedness info to pattern-bound variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3427,7 +3427,7 @@ altsWouldDup (alt:alts) | otherwise = not (all is_bot_alt alts) -- otherwise case: first alt is non-bot, so all the rest must be bot where - is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs + is_bot_alt (Alt _ _ _ rhs) = exprIsDeadEnd rhs ------------------------- mkDupableCont :: SimplEnv @@ -3615,9 +3615,9 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty mkDupableAlt :: Platform -> OutId -> JoinFloats -> OutAlt -> SimplM (JoinFloats, OutAlt) -mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs') +mkDupableAlt _platform case_bndr jfloats (Alt con freq bndrs' rhs') | exprIsTrivial rhs' -- See point (2) of Note [Duplicating join points] - = return (jfloats, Alt con bndrs' rhs') + = return (jfloats, Alt con freq bndrs' rhs') | otherwise = do { let rhs_ty' = exprType rhs' @@ -3645,7 +3645,7 @@ mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs') ; join_bndr <- newJoinId final_bndrs' rhs_ty' ; let join_call = mkApps (Var join_bndr) final_args - alt' = Alt con bndrs' join_call + alt' = Alt con freq bndrs' join_call ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) , alt') } diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 5c3114e76b..525dda7ed3 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -2268,15 +2268,15 @@ mkCase, mkCase1, mkCase2, mkCase3 -- 1. Merge Nested Cases -------------------------------------------------- -mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) +mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ _ deflt_rhs : outer_alts) | gopt Opt_CaseMerge dflags , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) <- stripTicksTop tickishFloatable deflt_rhs , inner_scrut_var == outer_bndr = do { tick (CaseMerge outer_bndr) - ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args) - (Alt con args (wrap_rhs rhs)) + ; let wrap_alt (Alt con freq args rhs) = assert (outer_bndr `notElem` args) + (Alt con freq args (wrap_rhs rhs)) -- Simplifier's no-shadowing invariant should ensure -- that outer_bndr is not shadowed by the inner patterns wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs @@ -2310,13 +2310,13 @@ mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts -- 2. Eliminate Identity Case -------------------------------------------------- -mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case +mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ _ rhs1 : _) -- Identity case | all identity_alt alts = do { tick (CaseIdentity case_bndr) ; return (mkTicks ticks $ re_cast scrut rhs1) } where - ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts) - identity_alt (Alt con args rhs) = check_eq rhs con args + ticks = concatMap (\(Alt _ _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts) + identity_alt (Alt con _freq args rhs) = check_eq rhs con args check_eq (Cast rhs co) con args -- See Note [RHS casts] = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args @@ -2358,7 +2358,7 @@ mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts mkCase2 dflags scrut bndr alts_ty alts | -- See Note [Scrutinee Constant Folding] case alts of -- Not if there is just a DEFAULT alternative - [Alt DEFAULT _ _] -> False + [Alt DEFAULT _ _ _] -> False _ -> True , gopt Opt_CaseFolding dflags , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut @@ -2394,11 +2394,11 @@ mkCase2 dflags scrut bndr alts_ty alts tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id -> CoreAlt -> SimplM (Maybe CoreAlt) - tx_alt tx_con mk_orig new_bndr (Alt con bs rhs) + tx_alt tx_con mk_orig new_bndr (Alt con freq bs rhs) = case tx_con con of Nothing -> return Nothing Just con' -> do { bs' <- mk_new_bndrs new_bndr con' - ; return (Just (Alt con' bs' rhs')) } + ; return (Just (Alt con' freq bs' rhs')) } where rhs' | isDeadBinder bndr = rhs | otherwise = bindNonRec bndr orig_val rhs @@ -2425,8 +2425,8 @@ mkCase2 dflags scrut bndr alts_ty alts add_default :: [CoreAlt] -> [CoreAlt] -- See Note [Literal cases] - add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts - add_default alts = alts + add_default (Alt (LitAlt {}) freq bs rhs : alts) = Alt DEFAULT freq bs rhs : alts + add_default alts = alts {- Note [Literal cases] ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 718c840c96..27dd473ab7 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1246,9 +1246,9 @@ scExpr' env (Case scrut b ty alts) } where sc_con_app con args scrut' -- Known constructor; simplify - = do { let Alt _ bs rhs = findAlt con alts - `orElse` Alt DEFAULT [] (mkImpossibleExpr ty) - alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) + = do { let Alt _ _ bs rhs = findAlt con alts + `orElse` Alt DEFAULT NoFreq [] (mkImpossibleExpr ty) + alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) ; scExpr alt_env' rhs } sc_vanilla scrut_usg scrut' -- Normal case @@ -1267,7 +1267,7 @@ scExpr' env (Case scrut b ty alts) ; return (foldr combineUsage scrut_usg' alt_usgs, Case scrut' b' (scSubstTy env ty) alts') } - sc_alt env scrut' b' (Alt con bs rhs) + sc_alt env scrut' b' (Alt con freq bs rhs) = do { let (env1, bs1) = extendBndrsWith RecArg env bs (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 ; (usg, rhs') <- scExpr env2 rhs @@ -1275,7 +1275,7 @@ scExpr' env (Case scrut b ty alts) scrut_occ = case con of DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) _ -> ScrutOcc emptyUFM - ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') } + ; return (usg', b_occ `combineOcc` scrut_occ, Alt con freq bs2 rhs') } scExpr' env (Let (NonRec bndr rhs) body) | isTyVar bndr -- Type-lets may be created by doBeta diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 7071932e2a..28c755dd1b 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1185,14 +1185,14 @@ specCase :: SpecEnv , Id , [CoreAlt] , UsageDetails) -specCase env scrut' case_bndr [Alt con args rhs] +specCase env scrut' case_bndr [Alt con freq args rhs] | isDictId case_bndr -- See Note [Floating dictionaries out of cases] , interestingDict env scrut' , not (isDeadBinder case_bndr && null sc_args') = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') - [Alt con args' (Var sc_arg')] + [Alt con freq args' (Var sc_arg')] | sc_arg' <- sc_args' ] -- Extend the substitution for RHS to map the *original* binders @@ -1216,7 +1216,7 @@ specCase env scrut' case_bndr [Alt con args rhs] flt_binds = scrut_bind : sc_binds (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds all_uds = flt_binds `addDictBinds` free_uds - alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs') + alt' = Alt con freq args' (wrapDictBindsE dumped_dbs rhs') ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } where (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) @@ -1245,10 +1245,10 @@ specCase env scrut case_bndr alts ; return (scrut, case_bndr', alts', uds_alts) } where (env_alt, case_bndr') = substBndr env case_bndr - spec_alt (Alt con args rhs) = do + spec_alt (Alt con freq args rhs) = do (rhs', uds) <- specExpr env_rhs rhs let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds - return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) + return (Alt con freq args' (wrapDictBindsE dumped_dbs rhs'), free_uds) where (env_rhs, args') = substBndrs env_alt args diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index c514054ec1..2b5f906283 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -223,9 +223,9 @@ satExpr (Case expr bndr ty alts) interesting_ids = do let (alts', sat_infos_alts) = unzip zipped_alts' return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing) where - satAlt (Alt con bndrs expr) = do + satAlt (Alt con freq bndrs expr) = do (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids - return (Alt con bndrs expr', sat_info_expr) + return (Alt con freq bndrs expr', sat_info_expr) satExpr (Let bind body) interesting_ids = do (body', sat_info_body, body_app) <- satExpr body interesting_ids diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 7cb9d6ad2f..e3f31aa5c5 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -145,12 +145,12 @@ wwExpr ww_opts (Case expr binder ty alts) = do -- See Note [Zapping Used Once info in WorkWrap] return (Case new_expr new_binder ty new_alts) where - ww_alt (Alt con binders rhs) = do + ww_alt (Alt con freq binders rhs) = do new_rhs <- wwExpr ww_opts rhs let new_binders = [ if isId b then zapIdUsedOnceInfo b else b | b <- binders ] -- See Note [Zapping Used Once info in WorkWrap] - return (Alt con new_binders new_rhs) + return (Alt con freq new_binders new_rhs) {- ************************************************************************ diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index f1791dfebf..fa68e12909 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -233,7 +233,7 @@ ppr_expr add_par expr@(App {}) _ -> parens (hang (pprParendExpr fun) 2 pp_args) } -ppr_expr add_par (Case expr var ty [Alt con args rhs]) +ppr_expr add_par (Case expr var ty [Alt con _freq args rhs]) = sdocOption sdocPrintCaseAsLet $ \case True -> add_par $ -- See Note [Print case as let] sep [ sep [ text "let! {" @@ -312,7 +312,7 @@ ppr_expr add_par (Tick tickish expr) False -> add_par (sep [ppr tickish, pprCoreExpr expr]) pprCoreAlt :: OutputableBndr a => Alt a -> SDoc -pprCoreAlt (Alt con args rhs) +pprCoreAlt (Alt con _freq args rhs) = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index ff57df697f..014efc4c00 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -899,7 +899,7 @@ match_alts :: RuleMatchEnv -> Maybe RuleSubst match_alts _ subst [] [] = return subst -match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) +match_alts renv subst (Alt c1 _f1 vs1 r1:alts1) (Alt c2 _f2 vs2 r2:alts2) | c1 == c2 = do { subst1 <- match renv' subst r1 r2 ; match_alts renv subst1 alts1 alts2 } @@ -1227,7 +1227,7 @@ ruleCheck env (Cast e _) = ruleCheck env e ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e ruleCheck env (Lam _ e) = ruleCheck env e ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | Alt _ _ r <- as] + unionManyBags [ruleCheck env r | Alt _ _ _ r <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 0addae9775..2ad5da4178 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -100,7 +100,7 @@ seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs seqAlts :: [CoreAlt] -> () seqAlts [] = () -seqAlts (Alt c bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts +seqAlts (Alt c _ bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index d741aa0351..25b053d8a6 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -257,7 +257,7 @@ simple_opt_expr env expr | isDeadBinder b , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' -- We don't need to be concerned about floats when looking for coerce. - , Just (Alt altcon bs rhs) <- findAlt (DataAlt con) as + , Just (Alt altcon _freq bs rhs) <- findAlt (DataAlt con) as = case altcon of DEFAULT -> go rhs _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs @@ -267,7 +267,7 @@ simple_opt_expr env expr -- Note [Getting the map/coerce RULE to work] | isDeadBinder b - , [Alt DEFAULT _ rhs] <- as + , [Alt DEFAULT _freq _ rhs] <- as , isCoVarType (varType b) , (Var fun, _args) <- collectArgs e , fun `hasKey` coercibleSCSelIdKey @@ -285,8 +285,8 @@ simple_opt_expr env expr go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co ---------------------- - go_alt env (Alt con bndrs rhs) - = Alt con bndrs' (simple_opt_expr env' rhs) + go_alt env (Alt con freq bndrs rhs) + = Alt con freq bndrs' (simple_opt_expr env' rhs) where (env', bndrs') = subst_opt_bndrs env bndrs @@ -1141,7 +1141,7 @@ exprIsConApp_maybe (in_scope, id_unf) expr float = FloatLet (NonRec bndr' rhs') in go subst' (float:floats) expr cont - go subst floats (Case scrut b _ [Alt con vars expr]) cont + go subst floats (Case scrut b _ [Alt con _freq vars expr]) cont = let scrut' = subst_expr subst scrut (subst', b') = subst_bndr subst b diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs index 04e6bc3274..8f051e9d0e 100644 --- a/compiler/GHC/Core/Stats.hs +++ b/compiler/GHC/Core/Stats.hs @@ -85,7 +85,7 @@ exprStats (Cast e co) = coStats co `plusCS` exprStats e exprStats (Tick _ e) = exprStats e altStats :: CoreAlt -> CoreStats -altStats (Alt _ bs r) = altBndrStats bs `plusCS` exprStats r +altStats (Alt _ _ bs r) = altBndrStats bs `plusCS` exprStats r altBndrStats :: [Var] -> CoreStats -- Charge one for the alternative, not for each binder @@ -135,4 +135,4 @@ pairSize :: (Var, CoreExpr) -> Int pairSize (b,e) = bndrSize b + exprSize e altSize :: CoreAlt -> Int -altSize (Alt _ bs e) = bndrsSize bs + exprSize e +altSize (Alt _ _ bs e) = bndrsSize bs + exprSize e diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 83e91ad21a..309c985642 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -374,9 +374,9 @@ substExpr subst expr where (subst', bndr') = substBndr subst bndr - go_alt subst (Alt con bndrs rhs) = Alt con bndrs' (substExpr subst' rhs) - where - (subst', bndrs') = substBndrs subst bndrs + go_alt subst (Alt con freq bndrs rhs) = Alt con freq bndrs' (substExpr subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs -- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' -- that should be used by subsequent substitutions. diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index aaf42eafd2..b4110b9600 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -82,9 +82,9 @@ tidyExpr env (Lam b e) ------------ Case alternatives -------------- tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt -tidyAlt env (Alt con vs rhs) +tidyAlt env (Alt con freq vs rhs) = tidyBndrs env vs =: \ (env', vs) -> - (Alt con vs (tidyExpr env' rhs)) + (Alt con freq vs (tidyExpr env' rhs)) ------------ Tickish -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index f8dadf8c16..0305cc9d19 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -224,7 +224,7 @@ inlineBoringOk e , exprIsTrivial a = go (credit-1) f go credit (Tick _ e) = go credit e -- dubious go credit (Cast e _) = go credit e - go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce] + go credit (Case scrut _ _ [Alt _ _ _ rhs]) -- See Note [Inline unsafeCoerce] | isUnsafeEqualityProof scrut = go credit rhs go _ (Var {}) = boringCxtOk go _ _ = boringCxtNotOk @@ -570,7 +570,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr _ -> funSize opts top_args fun (length val_args) voids ------------ - size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 + size_up_alt (Alt _con _freq _bndrs rhs) = size_up rhs `addSizeN` 10 -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index b2af755e78..68378c6e2e 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -33,6 +33,7 @@ module GHC.Core.Utils ( exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, altsAreExhaustive, + isComparisonApp_maybe, -- * Equality cheapEqExpr, cheapEqExpr', eqExpr, @@ -93,7 +94,7 @@ import GHC.Types.Tickish import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Unique -import GHC.Types.Basic ( Arity, FullArgCount ) +import GHC.Types.Basic import GHC.Types.Unique.Set import GHC.Data.FastString @@ -146,7 +147,7 @@ exprType other = pprPanic "exprType" (pprCoreExpr other) coreAltType :: CoreAlt -> Type -- ^ Returns the type of the alternatives right hand side -coreAltType alt@(Alt _ bs rhs) +coreAltType alt@(Alt _ _ bs rhs) = case occCheckExpand bs rhs_ty of -- Note [Existential variables and silly type synonyms] Just ty -> ty @@ -499,7 +500,7 @@ stripTicksE p expr = go expr go_bs (NonRec b e) = NonRec b (go e) go_bs (Rec bs) = Rec (map go_b bs) go_b (b, e) = (b, go e) - go_a (Alt c bs e) = Alt c bs (go e) + go_a (Alt c f bs e) = Alt c f bs (go e) stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] stripTicksT p expr = fromOL $ go expr @@ -515,7 +516,7 @@ stripTicksT p expr = fromOL $ go expr go_bs (NonRec _ e) = go e go_bs (Rec bs) = concatOL (map go_b bs) go_b (_, e) = go e - go_a (Alt _ _ e) = go e + go_a (Alt _ _ _ e) = go e {- ************************************************************************ @@ -575,7 +576,7 @@ mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr -- Make (case x of y { DEFAULT -> e } mkDefaultCase scrut case_bndr body - = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body] + = Case scrut case_bndr (exprType body) [Alt DEFAULT NoFreq [] body] mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr -- Use this function if possible, when building a case, @@ -583,7 +584,7 @@ mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr -- doesn't mention variables bound by the case -- See Note [Care with the type of a case expression] mkSingleAltCase scrut case_bndr con bndrs body - = Case scrut case_bndr case_ty [Alt con bndrs body] + = Case scrut case_bndr case_ty [Alt con NoFreq bndrs body] where body_ty = exprType body @@ -627,16 +628,16 @@ This makes it easy to find, though it makes matching marginally harder. -- | Extract the default case alternative findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) -findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs) -findDefault alts = (alts, Nothing) +findDefault (Alt DEFAULT _ args rhs : alts) = assert (null args) (alts, Just rhs) +findDefault alts = (alts, Nothing) addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] addDefault alts Nothing = alts -addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts +addDefault alts (Just rhs) = Alt DEFAULT NoFreq [] rhs : alts isDefaultAlt :: Alt b -> Bool -isDefaultAlt (Alt DEFAULT _ _) = True -isDefaultAlt _ = False +isDefaultAlt (Alt DEFAULT _ _ _) = True +isDefaultAlt _ = False -- | Find the case alternative corresponding to a particular -- constructor: panics if no such constructor exists @@ -645,11 +646,11 @@ findAlt :: AltCon -> [Alt b] -> Maybe (Alt b) -- See Note [Unreachable code] findAlt con alts = case alts of - (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt) - _ -> go alts Nothing + (deflt@(Alt DEFAULT _ _ _):alts) -> go alts (Just deflt) + _ -> go alts Nothing where go [] deflt = deflt - go (alt@(Alt con1 _ _) : alts) deflt + go (alt@(Alt con1 _ _ _) : alts) deflt = case con `cmpAltCon` con1 of LT -> deflt -- Missed it already; the alts are in increasing order EQ -> Just alt @@ -736,7 +737,7 @@ filterAlts _tycon inst_tys imposs_cons alts = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) where (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | Alt con _ _ <- alts_wo_default] + alt_cons = [con | Alt con _ _ _ <- alts_wo_default] trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default @@ -748,9 +749,9 @@ filterAlts _tycon inst_tys imposs_cons alts -- OR by a non-DEFAULT branch in this case expression. impossible_alt :: [Type] -> Alt b -> Bool - impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True - impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con - impossible_alt _ _ = False + impossible_alt _ (Alt con _ _ _) | con `Set.member` imposs_cons_set = True + impossible_alt inst_tys (Alt (DataAlt con) _ _ _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False -- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. -- See Note [Refine DEFAULT case alternatives] @@ -762,7 +763,7 @@ refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders -> [CoreAlt] -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts - | Alt DEFAULT _ rhs : rest_alts <- all_alts + | Alt DEFAULT _ _ rhs : rest_alts <- all_alts , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: -- case x of { DEFAULT -> e } @@ -779,7 +780,7 @@ refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts [] -> (False, rest_alts) -- It matches exactly one constructor, so fill it in: - [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs]) + [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) NoFreq (ex_tvs ++ arg_ids) rhs]) -- We need the mergeAlts to keep the alternatives in the right order where (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys @@ -962,25 +963,26 @@ combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT [CoreAlt]) -- New alternatives -- See Note [Combine identical alternatives] -- True <=> we did some combining, result is a single DEFAULT alternative -combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts) +combineIdenticalAlts imposs_deflt_cons (Alt con1 freq1 bndrs1 rhs1 : rest_alts) | all isDeadBinder bndrs1 -- Remember the default , not (null elim_rest) -- alternative comes first = (True, imposs_deflt_cons', deflt_alt : filtered_rest) where (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts - deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1) + elim_freqs = sum [ freq | Alt _ freq _ _ <- elim_rest ] + deflt_alt = Alt DEFAULT (elim_freqs + freq1) [] (mkTicks (concat tickss) rhs1) -- See Note [Care with impossible-constructors when combining alternatives] imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons - elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest + elim_cons = elim_con1 ++ map (\(Alt con _ _ _) -> con) elim_rest elim_con1 = case con1 of -- Don't forget con1! DEFAULT -> [] -- See Note [ _ -> [con1] cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 - identical_to_alt1 (Alt _con bndrs rhs) + identical_to_alt1 (Alt _con _freq bndrs rhs) = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 - tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest + tickss = map (\(Alt _ _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest combineIdenticalAlts imposs_cons alts = (False, imposs_cons, alts) @@ -991,7 +993,7 @@ scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] scaleAltsBy w alts = map scaleAlt alts where scaleAlt :: CoreAlt -> CoreAlt - scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs + scaleAlt (Alt con freq bndrs rhs) = Alt con freq (map scaleBndr bndrs) rhs scaleBndr :: CoreBndr -> CoreBndr scaleBndr b = scaleVarBy w b @@ -1332,7 +1334,7 @@ exprIsCheapX ok_app e go _ (Coercion {}) = True go n (Cast e _) = go n e go n (Case scrut _ _ alts) = ok scrut && - and [ go n rhs | Alt _ _ rhs <- alts ] + and [ go n rhs | Alt _ _ _ rhs <- alts ] go n (Tick t e) | tickishCounts t = False | otherwise = go n e go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e @@ -1617,7 +1619,7 @@ expr_ok primop_ok (Case scrut bndr _ alts) = -- See Note [exprOkForSpeculation: case expressions] expr_ok primop_ok scrut && isUnliftedType (idType bndr) - && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts + && all (\(Alt _ _ _ rhs) -> expr_ok primop_ok rhs) alts && altsAreExhaustive alts expr_ok primop_ok other_expr @@ -1707,7 +1709,7 @@ altsAreExhaustive :: [Alt b] -> Bool -- False <=> they may or may not be altsAreExhaustive [] = False -- Should not happen -altsAreExhaustive (Alt con1 _ _ : alts) +altsAreExhaustive (Alt con1 _ _ _ : alts) = case con1 of DEFAULT -> True LitAlt {} -> False @@ -2022,6 +2024,16 @@ exprIsTickedString_maybe (Tick t e) | otherwise = exprIsTickedString_maybe e exprIsTickedString_maybe _ = Nothing +-- | Is the expression an application to a primitive comparison operator +-- ('primOpIsComparison_maybe')? If so, return the kind of 'Comparison' +-- and the two argument expressions. +isComparisonApp_maybe :: CoreExpr -> Maybe (Comparison, CoreExpr, CoreExpr) +isComparisonApp_maybe e = do + App (App (Var f) a1) a2 <- pure e + op <- isPrimOpId_maybe f + cmp <- primOpIsComparison_maybe op + pure (cmp, a1, a2) + {- ************************************************************************ * * @@ -2201,7 +2213,7 @@ eqExpr in_scope e1 e2 go _ _ _ = False ----------- - go_alt env (Alt c1 bs1 e1) (Alt c2 bs2 e2) + go_alt env (Alt c1 _f1 bs1 e1) (Alt c2 _f2 bs2 e2) = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool @@ -2246,7 +2258,7 @@ diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) -- See Note [Empty case alternatives] in GHC.Data.TrieMap = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) where env' = rnBndr2 env b1 b2 - diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) + diffAlt (Alt c1 _f1 bs1 e1) (Alt c2 _f2 bs2 e2) | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 diffExpr _ _ e1 e2 |