Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 760fe6e0 by Simon Peyton Jones at 2026-01-02T14:02:20+00:00 Serious attempt to avoid duplicating large coercions [skip ci] - - - - - 8 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE MagicHash #-} + {- (c) The University of Glasgow 2006 -} @@ -23,6 +25,7 @@ module GHC.Core.Coercion ( coercionType, mkCoercionType, coercionKind, coercionLKind, coercionRKind,coercionKinds, coercionRole, coercionKindRole, + coercionIsSmall, -- ** Constructing coercions mkGReflCo, mkGReflMCo, mkReflCo, mkRepReflCo, mkNomReflCo, @@ -169,6 +172,8 @@ import qualified Data.Monoid as Monoid import Data.List.NonEmpty ( NonEmpty (..) ) import Control.DeepSeq +import GHC.Exts + {- %************************************************************************ %* * @@ -2468,6 +2473,40 @@ seqCos :: [Coercion] -> () seqCos [] = () seqCos (co:cos) = seqCo co `seq` seqCos cos +coercionIsSmall :: Coercion -> Bool +-- This function should return False quickly on a big coercion +-- It should /not/ traverse the big coercion! +coercionIsSmall co + = not (isTrue# ((go co 100#) <# 0#)) + where + go :: Coercion -> Int# -> Int# + go _co n | isTrue# (n <# 0#) = n + go (Refl {}) n = dec n + go (GRefl _ _ mco) n = go_mco mco (dec n) + go (TyConAppCo _ _ cos) n = go_cos cos (dec n) + go (AxiomCo _ cos) n = go_cos cos (dec n) + go (UnivCo _ _ _ _ cos) n = go_cos cos (dec n) + go (AppCo co1 co2) n = go co1 (go co2 (dec n)) + go (CoVarCo {}) n = dec n + go (HoleCo {}) n = dec n + go (SymCo co) n = go co (dec n) + go (KindCo co) n = go co (dec n) + go (SubCo co) n = go co (dec n) + go (TransCo co1 co2) n = go co1 (go co2 (dec n)) + go (SelCo _ co) n = go co (dec n) + go (LRCo _ co) n = go co (dec n) + go (InstCo co1 co2) n = go co1 (go co2 (dec n)) + go (ForAllCo _ _ _ kco co) n = go co (go_mco kco (dec n)) + go (FunCo _ _ _ mco aco rco) n = go mco (go aco (go rco (dec n))) + + go_cos [] n = n + go_cos (co:cos) n = go_cos cos (go co n) + + go_mco MRefl n = dec n + go_mco (MCo co) n = go co n + + dec n = n -# 1# + {- %************************************************************************ %* * ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -845,10 +845,8 @@ unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ where flag (Rec {}) = FltLifted flag (NonRec bndr rhs) - | not (isStrictId bndr) = FltLifted - | exprIsTickedString rhs = FltLifted - -- String literals can be floated freely. - -- See Note [Core top-level string literals] in GHC.Core. + | exprIsTopLevelBindable rhs (idType bndr) = FltLifted + -- Things that can float freely, including to top level | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) | otherwise = FltCareful ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -597,15 +597,20 @@ tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co) work_id = mkLocalIdWithInfo work_name ManyTy work_ty work_info is_strict = isStrictId bndr + ; (co_floats, co') <- makeCoTrivial co + ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict work_id (emptyFloats env) rhs ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs + ; let work_id_w_unf = work_id `setIdUnfolding` work_unf - floats = rhs_floats `addLetFloats` - unitLetFloat (NonRec work_id_w_unf work_rhs) + work_float = unitLetFloat (NonRec work_id_w_unf work_rhs) - triv_rhs = Cast (Var work_id_w_unf) co + floats = rhs_floats `addLetFloats` + (co_floats `addLetFlts` work_float) + + triv_rhs = Cast (Var work_id_w_unf) co' ; if postInlineUnconditionally env bind_cxt old_bndr bndr triv_rhs -- Almost always True, because the RHS is trivial @@ -715,12 +720,15 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs ; let all_floats = rhs_floats1 `addLetFloats` anf_floats ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2 then -- Float! + simplTrace "prepareBinding:yes" (ppr all_floats $$ text "rhs" <+> ppr rhs2) $ do { tick LetFloatFromLet ; return (all_floats, rhs2) } else -- Abandon floating altogether; revert to original rhs -- Since we have already built rhs1, we just need to add -- rhs_floats1 to it + simplTrace "prepareBinding:no" (vcat [ ppr all_floats + , text "rhs" <+> ppr rhs2 ]) $ return (emptyFloats env, wrapFloats rhs_floats1 rhs1) } {- Note [prepareRhs] @@ -753,7 +761,9 @@ prepareRhs :: HasDebugCallStack -- x = Just a -- See Note [prepareRhs] prepareRhs env top_lvl occ rhs0 - | is_expandable = anfise rhs0 + | is_expandable = do { (flts,rhs) <- anfise rhs0 + ; pprTrace "prepareRhs" (ppr rhs0 $$ text "new" <+> ppr rhs) $ + return (flts, rhs) } | otherwise = return (emptyLetFloats, rhs0) where -- We can't use exprIsExpandable because the WHOLE POINT is that @@ -762,7 +772,8 @@ prepareRhs env top_lvl occ rhs0 -- just say no! is_expandable = go rhs0 0 where - go (Var fun) n_val_args = isExpandableApp fun n_val_args + go (Var fun) n_val_args = pprTrace "is_exp" (ppr fun <+> ppr n_val_args $$ ppr (isExpandableApp fun n_val_args)) $ + isExpandableApp fun n_val_args go (App fun arg) n_val_args | isTypeArg arg = go fun n_val_args | otherwise = go fun (n_val_args + 1) @@ -772,8 +783,9 @@ prepareRhs env top_lvl occ rhs0 anfise :: OutExpr -> SimplM (LetFloats, OutExpr) anfise (Cast rhs co) - = do { (floats, rhs') <- anfise rhs - ; return (floats, Cast rhs' co) } + = do { (floats1, rhs') <- anfise rhs + ; (floats2, co') <- makeCoTrivial co + ; return (floats1 `addLetFlts` floats2, Cast rhs' co') } anfise (App fun (Type ty)) = do { (floats, rhs') <- anfise fun ; return (floats, App rhs' (Type ty)) } @@ -818,13 +830,19 @@ makeTrivial :: HasDebugCallStack -- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] makeTrivial env top_lvl dmd occ_fs expr | exprIsTrivial expr -- Already trivial - || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise - -- See Note [Cannot trivialise] - = return (emptyLetFloats, expr) + = simplTrace "makeTrivial:triv" (ppr expr) $ + return (emptyLetFloats, expr) + + | not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = simplTrace "makeTrivial:cannot" (ppr expr) $ + return (emptyLetFloats, expr) | Cast expr' co <- expr - = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' - ; return (floats, Cast triv_expr co) } + = do { (floats1, triv_co) <- makeCoTrivial co + ; (floats2, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' + ; simplTrace "makeTrivial:co" (ppr (Cast triv_expr triv_co)) $ + return (floats1 `addLetFlts` floats2, Cast triv_expr triv_co) } | otherwise -- 'expr' is not of form (Cast e co) = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr @@ -850,6 +868,17 @@ makeTrivial env top_lvl dmd occ_fs expr id_info = vanillaIdInfo `setDemandInfo` dmd expr_ty = exprType expr +makeCoTrivial :: OutCoercion -> SimplM (LetFloats, OutCoercion) +makeCoTrivial co + | coercionIsSmall co + = return (emptyLetFloats, co) + | otherwise + = do { co_uniq <- getUniqueM + ; let co_name = mkSystemVarName co_uniq (fsLit "aco") + co_var = mkLocalCoVar co_name (coercionType co) + ; return ( unitLetFloat (NonRec co_var (Coercion co)) + , mkCoVarCo co_var ) } + bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool -- True iff we can have a binding of this expression at this level -- Precondition: the type is the type of the expression @@ -1259,7 +1288,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env -- Because of the let-can-float invariant, it's ok to -- inline freely, or to drop the binding if it is dead. - = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $ + = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr <+> ppr rhs) $ tick (PreInlineUnconditionally bndr) ; simplExprF env' body cont } @@ -1758,12 +1787,12 @@ simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) ; simplLam (extendTvSubst env bndr arg_ty) body cont } -- Coercion beta-reduction -simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se - , sc_cont = cont }) - = assertPpr (isCoVar bndr) (ppr bndr) $ - do { tick (BetaReduction bndr) - ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co - ; simplLam (extendCvSubst env bndr arg_co') body cont } +-- simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se +-- , sc_cont = cont }) +-- = assertPpr (isCoVar bndr) (ppr bndr) $ +-- do { tick (BetaReduction bndr) +-- ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co +-- ; simplLam (extendCvSubst env bndr arg_co') body cont } -- Value beta-reduction -- This works for /coercion/ lambdas too @@ -1791,7 +1820,7 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly] not (exprIsTrivial arg) && not (isDeadOcc (idOccInfo bndr)) ) - -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $ + -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr <+> ppr arg) $ tick (PreInlineUnconditionally bndr) ; simplLam env' body cont } @@ -3688,9 +3717,9 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont = assert (isTyVar b ) bind_args (extendTvSubst env' b ty) bs' args - bind_args env' (b:bs') (Coercion co : args) - = assert (isCoVar b ) - bind_args (extendCvSubst env' b co) bs' args +-- bind_args env' (b:bs') (Coercion co : args) +-- = assert (isCoVar b ) +-- bind_args (extendCvSubst env' b co) bs' args bind_args env' (b:bs') (arg : args) = assert (isId b) $ ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1646,6 +1646,7 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] | isTopLevel (bindContextLevel bind_cxt) = False -- Note [Top level and postInlineUnconditionally] + | isCoVar bndr = False | exprIsTrivial rhs = True | BC_Join {} <- bind_cxt = False -- See point (1) of Note [Duplicating join points] -- in GHC.Core.Opt.Simplify.Iteration ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -191,7 +191,7 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc ppr_expr add_par (Var id) = ppr_id_occ add_par id ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird -ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) +ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> pprOptCo co) ppr_expr add_par (Lit lit) = pprLiteral add_par lit ppr_expr add_par (Cast expr co) ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -815,7 +815,7 @@ type CoercionN = Coercion -- always Nominal type CoercionR = Coercion -- always Representational type CoercionP = Coercion -- always Phantom -type MCoercionN = MCoercion -- alwyas Nominal +type MCoercionN = MCoercion -- always Nominal type MCoercionR = MCoercion -- always Representational {- Note [KindCoercion] ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -1280,37 +1280,44 @@ it off at source. -} {-# INLINE trivial_expr_fold #-} -trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r +trivial_expr_fold :: (Id -> r) -- Var + -> (Literal -> r) -- Lit + -> (Type -> r) -- Type + -> (Coercion -> r) -- Coercion + -> (r -> Coercion -> r) -- Cast + -> r -- Anything else + -> CoreExpr -> r -- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr] -- This is meant to have the code of both functions in one place and make it -- easy to derive custom predicates. -- --- (trivial_expr_fold k_id k_triv k_not_triv e) +-- (trivial_expr_fold k_id k_ty k_co k_not_triv e) -- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping) -- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping) --- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping) +-- * returns (k_ty ty) if `e` is a type (with trivial wrapping) +-- * returns (k_co co) if `e` is a coercion (with trivial wrapping) -- * returns k_not_triv otherwise -- -- where "trivial wrapping" is -- * Type application or abstraction -- * Ticks other than `tickishIsCode` -- * `case e of {}` an empty case -trivial_expr_fold k_id k_lit k_triv k_not_triv = go +trivial_expr_fold k_id k_lit k_ty k_co k_cast k_not_triv = go where -- If you change this function, be sure to change -- SetLevels.notWorthFloating as well! -- (Or yet better: Come up with a way to share code with this function.) go (Var v) = k_id v -- See Note [Variables are trivial] go (Lit l) | litIsTrivial l = k_lit l - go (Type _) = k_triv - go (Coercion _) = k_triv + go (Type ty) = k_ty ty + go (Coercion co) = k_co co + go (Cast e co) = k_cast (go e) co go (App f arg) | not (isRuntimeArg arg) = go f | exprIsUnaryClassFun f = go arg | otherwise = k_not_triv go (Lam b e) | not (isRuntimeVar b) = go e go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial] - go (Cast e _) = go e go (Case e b _ as) | null as = go e -- See Note [Empty case is trivial] @@ -1319,7 +1326,14 @@ trivial_expr_fold k_id k_lit k_triv k_not_triv = go go _ = k_not_triv exprIsTrivial :: CoreExpr -> Bool -exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e +exprIsTrivial e = trivial_expr_fold + (const True) -- Ids + (const True) -- Literals + (const True) -- Types + coercionIsSmall -- Coercions + (\ r co -> pprTrace "exprIsTrivial" (ppr (coercionIsSmall co) $$ ppr co) $ + r && coercionIsSmall co) -- Casts + False e {- Note [getIdFromTrivialExpr] @@ -1340,12 +1354,16 @@ T12076lit for an example where this matters. getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id -- See Note [getIdFromTrivialExpr] -getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e +getIdFromTrivialExpr e + = trivial_expr_fold id panic panic panic panic panic e where + panic :: forall a. a panic = pprPanic "getIdFromTrivialExpr" (ppr e) getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id -getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e +getIdFromTrivialExpr_maybe e + = trivial_expr_fold Just (const Nothing) (const Nothing) + (const Nothing) (\ r _ -> r) Nothing e {- ********************************************************************* * * @@ -2371,6 +2389,13 @@ exprIsTopLevelBindable expr ty -- as the latter would panic. || exprIsTickedString expr + || exprIsCoercion expr + +-- | Check if the expression is a literal coercion; these can appear at top level +exprIsCoercion :: CoreExpr -> Bool +exprIsCoercion (Coercion {}) = True +exprIsCoercion _ = False + -- | Check if the expression is zero or more Ticks wrapped around a literal -- string. exprIsTickedString :: CoreExpr -> Bool ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -598,8 +598,10 @@ getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg -- CoreArgs may not immediately look trivial, e.g., `case e of {}` or -- `case unsafeequalityProof of UnsafeRefl -> e` might intervene. -- Good thing we can just call `trivial_expr_fold` here. -getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg panic panic e +getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg + panic panic panic panic e where + panic :: forall a. a panic = pprPanic "getStgArgFromTrivialArg" (ppr e) coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/760fe6e02a2b9be0ef0b23d73a9b9fd6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/760fe6e02a2b9be0ef0b23d73a9b9fd6... You're receiving this email because of your account on gitlab.haskell.org.