Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: d5525fc9 by Simon Peyton Jones at 2026-01-16T17:41:21+00:00 Flags for tracing coercion sizes - - - - - 7 changed files: - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Driver/Config/Core/Opt/Simplify.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs Changes: ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -257,32 +257,36 @@ optCoAlt is (Alt k bs e) left-to-right, and won't spot (co1 ; co2 ; sym co2) -} -optCoRefl :: Subst -> Coercion -> Coercion +optCoRefl :: Bool -> Subst -> Coercion -> Coercion -- See Note [optCoRefl] -optCoRefl subst in_co +optCoRefl check_stuff subst in_co | isEmptyTCvSubst subst = in_co - - | otherwise -#ifndef DEBUG - = opt_co_refl subst in_co -#else - -- Debug check that optCoRefl doesn't change the type + | not check_stuff = opt_co_refl subst in_co + | otherwise -- Do expensive checks = let out_co = opt_co_refl subst in_co (Pair in_l in_r) = coercionKind in_co (Pair out_l out_r) = coercionKind out_co in_l' = substTy subst in_l in_r' = substTy subst in_r - in if (in_l' `eqType` out_l) && (in_r' `eqType` out_r) - then out_co - else pprTrace "optReflCo" (vcat [ text "in_l':" <+> ppr in_l' - , text "in_r':" <+> ppr in_r' - , text "out_l:" <+> ppr out_l - , text "out_r:" <+> ppr out_r - , text "in_co:" <+> ppr in_co - , text "out_co:" <+> ppr out_co ]) $ + in_co' = substCo subst in_co + in_sz = coercionSize in_co' + out_sz = coercionSize out_co + in if not ((in_l' `eqType` out_l) && (in_r' `eqType` out_r)) + then pprTrace "Yikes: optReflCo changes type" + (vcat [ text "in_l':" <+> ppr in_l' + , text "in_r':" <+> ppr in_r' + , text "out_l:" <+> ppr out_l + , text "out_r:" <+> ppr out_r + , text "in_co:" <+> ppr in_co + , text "out_co:" <+> ppr out_co ]) $ out_co -#endif - + else if out_sz < in_sz + then pprTrace "optCoRefl: size reduction:" + (vcat [ int in_sz <+> text "-->" <+> int out_sz + , text "in_co':" <+> ppr in_co' + , text "out_co:" <+> ppr out_co ]) $ + out_co + else out_co opt_co_refl :: Subst -> InCoercion -> OutCoercion opt_co_refl subst co = go co ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -284,6 +284,8 @@ data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad , sm_rule_opts :: !RuleOpts , sm_case_folding :: !Bool , sm_case_merge :: !Bool + , sm_opt_refl_co :: !Bool + , sm_check_opt_co :: !Bool } -- | See Note [SimplPhase] ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -26,7 +26,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBind import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) import qualified GHC.Core.Make import GHC.Core.Coercion hiding ( substCo, substCoVar ) --- import GHC.Core.Coercion.Opt +import GHC.Core.Coercion.Opt import GHC.Core.Reduction import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon @@ -1390,9 +1390,12 @@ simplCoercionF env co cont simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co - = do { let out_co = -- optCoRefl (getTCvSubst env) co - substCo env co + = do { let out_co | sm_opt_refl_co mode = optCoRefl (sm_check_opt_co mode) + (getTCvSubst env) co + | otherwise = substCo env co ; seqCo out_co `seq` return out_co } + where + mode = seMode env ----------------------------------- -- | Push a TickIt context outwards past applications and cases, as ===================================== compiler/GHC/Driver/Config/Core/Opt/Simplify.hs ===================================== @@ -16,7 +16,7 @@ import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) ) import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig ) import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts ) -import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), gopt ) +import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), DumpFlag(..), gopt, dopt ) import GHC.Runtime.Context ( InteractiveContext(..) ) @@ -72,6 +72,8 @@ initSimplMode dflags phase name = SimplMode , sm_rule_opts = initRuleOpts dflags , sm_case_folding = gopt Opt_CaseFolding dflags , sm_case_merge = gopt Opt_CaseMerge dflags + , sm_opt_refl_co = gopt Opt_OptReflCoercion dflags + , sm_check_opt_co = dopt Opt_D_opt_co dflags } initGentleSimplMode :: DynFlags -> SimplMode ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1233,6 +1233,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_OptReflCoercion ) -- See Note [Coercion optimisation] in GHC.Core.Coercion.Opt , ([2], Opt_OptCoercion ) -- See Note [Coercion optimisation] in GHC.Core.Coercion.Opt , ([2], Opt_DictsStrict) ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -530,6 +530,8 @@ data DumpFlag | Opt_D_dump_faststrings | Opt_D_faststring_stats | Opt_D_ipe_stats + | Opt_D_opt_co -- Check the coercion optimisations, + -- and report ones that reduce size deriving (Eq, Show, Enum) -- | Helper function to query whether a given `DumpFlag` is enabled or not. @@ -640,6 +642,7 @@ data GeneralFlag | Opt_InlineGenericsAggressively | Opt_StaticArgumentTransformation | Opt_OptCoercion + | Opt_OptReflCoercion | Opt_CSE | Opt_StgCSE | Opt_StgLiftLams @@ -909,6 +912,7 @@ optimisationFlags = EnumSet.fromList , Opt_StaticArgumentTransformation , Opt_PolymorphicSpecialisation , Opt_OptCoercion + , Opt_OptReflCoercion , Opt_CSE , Opt_StgCSE , Opt_StgLiftLams ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1657,6 +1657,8 @@ dynamic_flags_deps = [ (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) , make_ord_flag defGhcFlag "dipe-stats" (setDumpFlag Opt_D_ipe_stats) + , make_ord_flag defGhcFlag "dcheck-opt-co" + (setDumpFlag Opt_D_opt_co) , make_ord_flag defGhcFlag "dfaststring-stats" (setDumpFlag Opt_D_faststring_stats) , make_ord_flag defGhcFlag "dno-llvm-mangler" @@ -2472,6 +2474,7 @@ fFlagsDeps = [ flagSpec "cmm-sink" Opt_CmmSink, flagSpec "cmm-static-pred" Opt_CmmStaticPred, flagSpec "opt-coercion" Opt_OptCoercion, + flagSpec "opt-refl-coercion" Opt_OptReflCoercion, 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/d5525fc95f6da178eabe85d5627f2044... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5525fc95f6da178eabe85d5627f2044... You're receiving this email because of your account on gitlab.haskell.org.