Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC Commits: f0432100 by Simon Peyton Jones at 2025-05-08T17:23:19+01:00 Be keen on postInlineUnconditionally into bottoming expressions Probably little or no effect - - - - - 4 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Types/Basic.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -33,7 +33,7 @@ import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Core import GHC.Core.FVs -import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, +import GHC.Core.Utils ( exprIsTrivial, isExpandableApp, mkCastMCo, mkTicks ) import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion @@ -2605,9 +2605,9 @@ occAnalArgs !env fun args !one_shots -- Make bottoming functions interesting -- See Note [Bottoming function calls] --- encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut --- | otherwise = OccVanilla - encl = OccVanilla + encl | Var f <- fun, isDeadEndId f = OccBot + | otherwise = OccVanilla +-- encl = OccVanilla go uds fun [] _ = WUD uds fun go uds fun (arg:args) one_shots @@ -2680,7 +2680,7 @@ occAnalApp !env (Var fun, args, ticks) occAnalApp env (Var fun_id, args, ticks) = WUD all_uds (mkTicks ticks app') where - -- Lots of banged bindings: this is a very heavily bit of code, + -- Lots of banged bindings: this is a very heavily-used bit of code, -- so it pays not to make lots of thunks here, all of which -- will ultimately be forced. !(fun', fun_id') = lookupBndrSwap env fun_id @@ -2709,7 +2709,7 @@ occAnalApp env (Var fun_id, args, ticks) !n_val_args = valArgCount args !n_args = length args !int_cxt = case occ_encl env of - OccScrut -> IsInteresting + OccBot -> IsInteresting _other | n_val_args > 0 -> IsInteresting | otherwise -> NotInteresting @@ -2893,14 +2893,20 @@ OccEncl is used to control whether to inline into constructor arguments. data OccEncl -- See Note [OccEncl] = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda - | OccScrut -- Scrutintee of a case + | OccBot -- We are in a bottoming expression | OccVanilla -- Everything else instance Outputable OccEncl where ppr OccRhs = text "occRhs" - ppr OccScrut = text "occScrut" + ppr OccBot = text "occBot" ppr OccVanilla = text "occVanilla" +setOccEncl :: OccEncl -> OccEncl -> OccEncl +-- (outer_encl `setOccEncl` inner_encl) +-- If we are in a bottoming context, don't forget it! +setOccEncl OccBot _ = OccBot +setOccEncl _ inner_encl = inner_encl + -- See Note [OneShots] type OneShots = [OneShotInfo] @@ -2922,16 +2928,17 @@ noBinderSwaps :: OccEnv -> Bool noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv -setScrutCtxt !env alts +setScrutCtxt !env _alts = setNonTailCtxt encl env where - encl | interesting_alts = OccScrut - | otherwise = OccVanilla + encl = OccVanilla +-- encl | interesting_alts = OccScrut +-- | otherwise = OccVanilla - interesting_alts = case alts of - [] -> False - [alt] -> not (isDefaultAlt alt) - _ -> True +-- interesting_alts = case alts of +-- [] -> False +-- [alt] -> not (isDefaultAlt alt) +-- _ -> True -- 'interesting_alts' is True if the case has at least one -- non-default alternative. That in turn influences -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! @@ -2974,13 +2981,14 @@ For a join point binding, j x = rhs -} setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv -setNonTailCtxt ctxt !env - = env { occ_encl = ctxt +setNonTailCtxt inner_encl env@(OccEnv { occ_encl = outer_encl }) + = env { occ_encl = outer_encl `setOccEncl` inner_encl , occ_one_shots = [] , occ_join_points = zapJoinPointInfo (occ_join_points env) } setTailCtxt :: OccEnv -> OccEnv -setTailCtxt !env = env { occ_encl = OccVanilla } +setTailCtxt env@(OccEnv { occ_encl = outer_encl }) + = env { occ_encl = outer_encl `setOccEncl` OccVanilla } -- Preserve occ_one_shots, occ_join points -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt): @@ -3619,7 +3627,7 @@ data LocalOcc -- See Note [LocalOcc] , lo_tail :: !TailCallInfo -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3) -- gives NoTailCallInfo - , lo_int_cxt :: !InterestingCxt } + , lo_int_cxt :: !OccCtxt } | ManyOccL !TailCallInfo instance Outputable LocalOcc where @@ -3676,7 +3684,7 @@ andUDs, orUDs andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc -mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails +mkOneOcc :: OccEnv -> Id -> OccCtxt -> JoinArity -> UsageDetails mkOneOcc !env id int_cxt arity | not (isLocalId id) = emptyDetails @@ -4087,7 +4095,7 @@ orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc orLocalOcc (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = tci1 }) (OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = tci2 }) = OneOccL { lo_n_br = nbr1 + nbr2 - , lo_int_cxt = int_cxt1 `mappend` int_cxt2 + , lo_int_cxt = int_cxt1 `orOccCtxt` int_cxt2 , lo_tail = tci1 `andTailCallInfo` tci2 } orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2 ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -3940,6 +3940,8 @@ mkDupableContWithDmds env _ ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } where + thumbsUpPlanA _ = False + {- thumbsUpPlanA (StrictArg {}) = False thumbsUpPlanA (StrictBind {}) = True thumbsUpPlanA (Stop {}) = True @@ -3948,6 +3950,7 @@ mkDupableContWithDmds env _ thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k + -} mkDupableContWithDmds env dmds (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1630,8 +1630,8 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs is_demanded = isStrUsedDmd (idDemandInfo bndr) occ_info = idOccInfo old_bndr unfolding = idUnfolding bndr - arity = idArity bndr --- is_cheap = isCheapUnfolding unfolding +-- arity = idArity bndr + is_cheap = isCheapUnfolding unfolding uf_opts = seUnfoldingOpts env phase = sePhase env active = isActive phase (idInlineActivation bndr) @@ -1649,7 +1649,7 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs check_one_occ NotInsideLam NotInteresting n_br = not is_top_lvl && code_dup_ok n_br check_one_occ NotInsideLam IsInteresting n_br = code_dup_ok n_br check_one_occ IsInsideLam NotInteresting _ = False - check_one_occ IsInsideLam IsInteresting n_br = arity > 0 && code_dup_ok n_br + check_one_occ IsInsideLam IsInteresting n_br = is_cheap && code_dup_ok n_br -- IsInteresting: inlining inside a lambda only with good reason -- See the notes on int_cxt in preInlineUnconditionally -- arity>0: do not inline data strutures under lambdas, only functions ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -75,7 +75,7 @@ module GHC.Types.Basic ( InsideLam(..), BranchCount, oneBranch, - InterestingCxt(..), + OccCtxt(..), orOccCtxt, TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, isAlwaysTailCalled, @@ -1190,7 +1190,7 @@ data OccInfo -- See Note [OccInfo] | OneOcc { occ_in_lam :: !InsideLam , occ_n_br :: {-# UNPACK #-} !BranchCount - , occ_int_cxt :: !InterestingCxt + , occ_int_cxt :: !OccCtxt , occ_tail :: !TailCallInfo } -- ^ Occurs exactly once (per branch), not inside a rule @@ -1241,22 +1241,15 @@ seqOccInfo occ = occ `seq` () ----------------- -- | Interesting Context -data InterestingCxt - = IsInteresting - -- ^ Function: is applied - -- Data value: scrutinised by a case with at least one non-DEFAULT branch - | NotInteresting +data OccCtxt + = IsInteresting -- ^ All occurrences are in a bottoming context + -- or are applied to a value argument + | NotInteresting -- ^ Neither of the above deriving (Eq) --- | If there is any 'interesting' identifier occurrence, then the --- aggregated occurrence info of that identifier is considered interesting. -instance Semi.Semigroup InterestingCxt where - NotInteresting <> x = x - IsInteresting <> _ = IsInteresting - -instance Monoid InterestingCxt where - mempty = NotInteresting - mappend = (Semi.<>) +orOccCtxt :: OccCtxt -> OccCtxt -> OccCtxt +orOccCtxt IsInteresting IsInteresting = IsInteresting +orOccCtxt _ _ = NotInteresting ----------------- -- | Inside Lambda @@ -1340,11 +1333,11 @@ instance Outputable OccInfo where ppr (OneOcc inside_lam one_branch int_cxt tail_info) = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail where - pp_lam IsInsideLam = char 'L' - pp_lam NotInsideLam = empty - pp_args IsInteresting = char '!' - pp_args NotInteresting = empty - pp_tail = pprShortTailCallInfo tail_info + pp_lam IsInsideLam = char 'L' + pp_lam NotInsideLam = empty + pp_args NotInteresting = empty + pp_args IsInteresting = char '!' + pp_tail = pprShortTailCallInfo tail_info pprShortTailCallInfo :: TailCallInfo -> SDoc pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) @@ -2461,4 +2454,4 @@ convImportLevel NotLevelled = NormalLevel convImportLevelSpec :: ImportDeclLevel -> ImportLevel convImportLevelSpec ImportDeclQuote = QuoteLevel -convImportLevelSpec ImportDeclSplice = SpliceLevel \ No newline at end of file +convImportLevelSpec ImportDeclSplice = SpliceLevel View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f04321002d120f66b062972642a3386a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f04321002d120f66b062972642a3386a... You're receiving this email because of your account on gitlab.haskell.org.