Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: c1cde247 by Simon Peyton Jones at 2025-12-16T16:38:48+00:00 Make coercion optimisation into its own pass In this MR: * -fopt-coercion / -fno-opt-coercion switches the pass on and off * -fopt-coercion is on by default * The pass runs just once, right at the start of the pipeline - - - - - 10 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Pipeline/Types.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Driver/Config.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -69,7 +69,8 @@ module GHC.Core.Coercion ( isReflKindCo,isReflKindMCo, isReflCo, isReflCo_maybe, - isReflexiveMCo, isReflexiveCo, isReflexiveCo_maybe, + isReflexiveMCo, isReflexiveCo, + isReflexiveCoIgnoringMultiplicity, isReflCoVar_maybe, mkGReflLeftMCo, mkGReflRightMCo, mkCoherenceRightMCo, @@ -665,7 +666,9 @@ isReflCoVar_maybe cv -- See Note [KindCoercion] in GHC.Core.TyCo.Rep isKindCo :: Coercion -> Bool isKindCo co - = role == Nominal && isLiftedTypeKind kk1 && isLiftedTypeKind kk2 + = role == Nominal + && definitelyLiftedType kk1 + && definitelyLiftedType kk2 where (Pair kk1 kk2, role) = coercionKindRole co @@ -679,8 +682,14 @@ isKindCo co -- so we return True -- See Note [KindCoercion] in GHC.Core.TyCo.Rep isReflKindCo :: HasDebugCallStack => KindCoercion -> Bool -isReflKindCo co@(GRefl {}) = assertPpr (isKindCo co) (ppr co) $ +isReflKindCo co@(GRefl {}) = assertPpr (isKindCo co) (ppr co $$ ppr kk1 $$ ppr kk2 + $$ ppr (isLiftedTypeKind kk1) + $$ ppr (isLiftedTypeKind kk2) + $$ ppr (role == Nominal) + $$ ppr (isKindCo co)) True + where + (Pair kk1 kk2, role) = coercionKindRole co isReflKindCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl isReflKindCo _ = False @@ -700,7 +709,7 @@ isReflCo _ = False -- | Returns the type coerced if this coercion is reflexive. Guaranteed -- to work very quickly. Sometimes a coercion can be reflexive, but not --- obviously so. c.f. 'isReflexiveCo_maybe' +-- obviously so. isReflCo_maybe :: Coercion -> Maybe (Type, Role) isReflCo_maybe (Refl ty) = Just (ty, Nominal) isReflCo_maybe (GRefl r ty mco) | isReflKindMCo mco = Just (ty, r) @@ -709,27 +718,26 @@ isReflCo_maybe _ = Nothing -- | Slowly checks if the coercion is reflexive. Don't call this in a loop, -- as it walks over the entire coercion. isReflexiveCo :: Coercion -> Bool -isReflexiveCo (Refl {}) = True -isReflexiveCo (GRefl _ _ mco) = isReflKindMCo mco -isReflexiveCo (SymCo co) = isReflexiveCo co -isReflexiveCo co = coercionLKind co `eqType` coercionRKind co +isReflexiveCo co + = case co of + Refl {} -> True + GRefl _ _ mco -> isReflKindMCo mco + SymCo co -> isReflexiveCo co + _ -> coercionLKind co `eqType` coercionRKind co + +-- | Just like isReflexiveCo but ignores multiplicity +isReflexiveCoIgnoringMultiplicity :: Coercion -> Bool +isReflexiveCoIgnoringMultiplicity co + = case co of + Refl {} -> True + GRefl _ _ mco -> isReflKindMCo mco + SymCo co -> isReflexiveCoIgnoringMultiplicity co + _ -> coercionLKind co `eqTypeIgnoringMultiplicity` coercionRKind co isReflexiveMCo :: MCoercion -> Bool isReflexiveMCo MRefl = True isReflexiveMCo (MCo co) = isReflexiveCo co --- | Extracts the coerced type from a reflexive coercion. This potentially --- walks over the entire coercion, so avoid doing this in a loop. -isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) -isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) -isReflexiveCo_maybe (GRefl r ty mco) | isReflKindMCo mco = Just (ty, r) -isReflexiveCo_maybe co - | ty1 `eqType` ty2 - = Just (ty1, r) - | otherwise - = Nothing - where (Pair ty1 ty2, r) = coercionKindRole co - forAllCoKindCo :: TyCoVar -> KindMCoercion -> KindCoercion -- Get the kind coercion from a ForAllCo forAllCoKindCo _ (MCo co) = co ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -1,9 +1,8 @@ -- (c) The University of Glasgow 2006 - {-# LANGUAGE CPP #-} module GHC.Core.Coercion.Opt - ( optCoercion + ( optCoProgram, optCoercion , OptCoercionOpts (..) ) where @@ -12,6 +11,7 @@ import GHC.Prelude import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType ) +import GHC.Core import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst import GHC.Core.TyCo.Compare( eqForAllVis, eqTypeIgnoringMultiplicity ) @@ -164,6 +164,54 @@ We use the following invariants: to the little bits being substituted. -} +{- ********************************************************************** +%* * + optCoercionPgm +%* * +%********************************************************************* -} + +optCoProgram :: CoreProgram -> CoreProgram +optCoProgram binds + = map go binds + where + go (NonRec b r) = NonRec b (optCoExpr in_scope r) + go (Rec prs) = Rec (mapSnd (optCoExpr in_scope) prs) + in_scope = mkInScopeSetList (bindersOfBinds binds) + -- Put all top-level binders into scope; it is possible to have + -- forward references. See Note [Glomming] in GHC.Core.Opt.OccurAnal + +optCoExpr :: InScopeSet -> CoreExpr -> CoreExpr +optCoExpr _ e@(Var {}) = e +optCoExpr _ e@(Lit {}) = e +optCoExpr _ e@(Type {}) = e +optCoExpr is (App e1 e2) = App (optCoExpr is e1) (optCoExpr is e2) +optCoExpr is (Lam b e) = Lam b (optCoExpr (is `extendInScopeSet` b) e) +optCoExpr is (Coercion co) = Coercion (optCo is co) +optCoExpr is (Cast e co) = Cast (optCoExpr is e) (optCo is co) +optCoExpr is (Tick t e) = Tick t (optCoExpr is e) +optCoExpr is (Let (NonRec b r) e) = Let (NonRec b (optCoExpr is r)) + (optCoExpr (is `extendInScopeSet` b) e) +optCoExpr is (Let (Rec prs) e) = Let (Rec (mapSnd (optCoExpr is') prs)) + (optCoExpr is' e) + where + is' = is `extendInScopeSetList` map fst prs +optCoExpr is (Case e b ty alts) = Case (optCoExpr is e) b ty + (map (optCoAlt (is `extendInScopeSet` b)) alts) + +optCo :: InScopeSet -> Coercion -> Coercion +optCo is co = optCoercion' (mkEmptySubst is) co + +optCoAlt :: InScopeSet -> CoreAlt -> CoreAlt +optCoAlt is (Alt k bs e) + = Alt k bs (optCoExpr (is `extendInScopeSetList` bs) e) + + +{- ********************************************************************** +%* * + optCoercion +%* * +%********************************************************************* -} + -- | Coercion optimisation options newtype OptCoercionOpts = OptCoercionOpts { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) @@ -624,7 +672,7 @@ opt_univ env sym prov deps role ty1 ty2 in -- We only Lint multiplicities in the output of the typechecker, as -- described in Note [Linting linearity] in GHC.Core.Lint. This means - -- we can use 'eqTypeIgnoringMultiplicity' instea of 'eqType' below. + -- we can use 'eqTypeIgnoringMultiplicity' instead of 'eqType' below. -- -- In particular, this gets rid of 'SubMultProv' coercions that were -- introduced for typechecking multiplicities of data constructors, as ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -24,6 +24,7 @@ import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core import GHC.Core.SimpleOpt (simpleOptPgm) import GHC.Core.Opt.CSE ( cseProgram ) +import GHC.Core.Coercion.Opt ( optCoProgram ) import GHC.Core.Rules ( RuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreBindings, pprRules ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) @@ -134,6 +135,7 @@ getCoreToDo dflags hpt_rule_base extra_vars strictness = gopt Opt_Strictness dflags full_laziness = gopt Opt_FullLaziness dflags do_specialise = gopt Opt_Specialise dflags + do_co_opt = gopt Opt_OptCoercion dflags do_float_in = gopt Opt_FloatIn dflags cse = gopt Opt_CSE dflags spec_constr = gopt Opt_SpecConstr dflags @@ -146,7 +148,6 @@ getCoreToDo dflags hpt_rule_base extra_vars static_ptrs = xopt LangExt.StaticPointers dflags profiling = ways dflags `hasWay` WayProf - do_presimplify = do_specialise -- TODO: any other optimizations benefit from pre-simplification? do_simpl3 = const_fold || rules_on -- TODO: any other optimizations benefit from three-phase simplification? maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) @@ -215,12 +216,14 @@ getCoreToDo dflags hpt_rule_base extra_vars -- after this before anything else runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), - -- initial simplify: mk specialiser happy: minimum effort please - runWhen do_presimplify simpl_gently, - + -- Initial simplify: make specialiser happy and/or optimise coercions: + -- minimum effort please -- Specialisation is best done before full laziness -- so that overloaded functions have all their dictionary lambdas manifest - runWhen do_specialise CoreDoSpecialising, + runWhen (do_specialise || do_co_opt) $ + CoreDoPasses [ simpl_gently + , runWhen do_co_opt CoreOptCoercion + , runWhen do_specialise CoreDoSpecialising ], if full_laziness then CoreDoFloatOutwards $ FloatOutSwitches @@ -496,6 +499,9 @@ doCorePass pass guts = do CoreCSE -> {-# SCC "CommonSubExpr" #-} updateBinds cseProgram + CoreOptCoercion -> {-# SCC "OptCoercion" #-} + updateBinds optCoProgram + CoreLiberateCase -> {-# SCC "LiberateCase" #-} updateBinds (liberateCase (initLiberateCaseOpts dflags)) ===================================== compiler/GHC/Core/Opt/Pipeline/Types.hs ===================================== @@ -52,6 +52,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoSpecialising | CoreDoSpecConstr | CoreCSE + | CoreOptCoercion -- Run the coercion optimiser | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules -- matching this string | CoreDoNothing -- Useful when building up @@ -81,6 +82,7 @@ instance Outputable CoreToDo where ppr CoreDoSpecialising = text "Specialise" ppr CoreDoSpecConstr = text "SpecConstr" ppr CoreCSE = text "Common sub-expression" + ppr CoreOptCoercion = text "Optimise coercions" ppr CoreDesugar = text "Desugar (before optimization)" ppr CoreDesugarOpt = text "Desugar (after optimization)" ppr CoreTidy = text "Tidy Core" ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1531,8 +1531,11 @@ rebuild_go env expr cont Stop {} -> return (emptyFloats env, expr) TickIt t cont -> rebuild_go env (mkTick t expr) cont CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } - | isReflexiveCo co -> rebuild_go env expr cont - | otherwise -> rebuild_go env (mkCast expr co') cont + | isReflexiveCoIgnoringMultiplicity co + -- ignoring multiplicity: c.f. GHC.Core.Coercion.Opt.opt_univ + -> rebuild_go env expr cont + | otherwise + -> rebuild_go env (mkCast expr co') cont -- NB: mkCast implements the (Coercion co |> g) optimisation where co' = optOutCoercion env co opt ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -17,7 +17,7 @@ import GHCi.Message (EvalOpts(..)) -- | Initialise coercion optimiser configuration from DynFlags initOptCoercionOpts :: DynFlags -> OptCoercionOpts initOptCoercionOpts dflags = OptCoercionOpts - { optCoercionEnabled = not (hasNoOptCoercion dflags) + { optCoercionEnabled = gopt Opt_OptCoercion dflags } -- | Initialise Simple optimiser configuration from DynFlags ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -77,6 +77,7 @@ initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig coreDumpFlag :: CoreToDo -> Maybe DumpFlag coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core +coreDumpFlag (CoreOptCoercion {}) = Just Opt_D_verbose_core2core coreDumpFlag CoreDoFloatInwards = Just Opt_D_dump_float_in coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_dump_float_out coreDumpFlag CoreLiberateCase = Just Opt_D_dump_liberate_case ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -996,7 +996,7 @@ hasNoStateHack :: DynFlags -> Bool hasNoStateHack = gopt Opt_G_NoStateHack hasNoOptCoercion :: DynFlags -> Bool -hasNoOptCoercion = gopt Opt_G_NoOptCoercion +hasNoOptCoercion flags = not (gopt Opt_OptCoercion flags) -- | Test whether a 'DumpFlag' is set dopt :: DumpFlag -> DynFlags -> Bool @@ -1237,6 +1237,7 @@ optLevelFlags -- see Note [Documenting optimisation flags] , ([1,2], Opt_DoCleverArgEtaExpansion) -- See Note [Eta expansion of arguments in CorePrep] , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] , ([0,1,2], Opt_ProfManualCcs ) + , ([0,1,2], Opt_OptCoercion ) , ([2], Opt_DictsStrict) , ([0], Opt_IgnoreInterfacePragmas) ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -641,6 +641,7 @@ data GeneralFlag | Opt_InlineGenerics | Opt_InlineGenericsAggressively | Opt_StaticArgumentTransformation + | Opt_OptCoercion | Opt_CSE | Opt_StgCSE | Opt_StgLiftLams @@ -887,7 +888,6 @@ data GeneralFlag | Opt_PluginTrustworthy | Opt_G_NoStateHack - | Opt_G_NoOptCoercion deriving (Eq, Show, Enum) -- | The set of flags which affect optimisation for the purposes of @@ -910,6 +910,7 @@ optimisationFlags = EnumSet.fromList , Opt_CrossModuleSpecialise , Opt_StaticArgumentTransformation , Opt_PolymorphicSpecialisation + , Opt_OptCoercion , Opt_CSE , Opt_StgCSE , Opt_StgLiftLams ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1328,8 +1328,6 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_NoHsMain)) , make_ord_flag defGhcFlag "fno-state-hack" (NoArg (setGeneralFlag Opt_G_NoStateHack)) - , make_ord_flag defGhcFlag "fno-opt-coercion" - (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) , make_ord_flag defGhcFlag "with-rtsopts" (HasArg setRtsOpts) , make_ord_flag defGhcFlag "rtsopts" @@ -2477,6 +2475,7 @@ fFlagsDeps = [ flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, flagSpec "cmm-sink" Opt_CmmSink, flagSpec "cmm-static-pred" Opt_CmmStaticPred, + flagSpec "opt-coercion" Opt_OptCoercion, flagSpec "cse" Opt_CSE, flagSpec "stg-cse" Opt_StgCSE, flagSpec "stg-lift-lams" Opt_StgLiftLams, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1cde2471159acb0e17134cbbadf0842... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1cde2471159acb0e17134cbbadf0842... You're receiving this email because of your account on gitlab.haskell.org.