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
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:
| ... | ... | @@ -257,32 +257,36 @@ optCoAlt is (Alt k bs e) |
| 257 | 257 | left-to-right, and won't spot (co1 ; co2 ; sym co2)
|
| 258 | 258 | -}
|
| 259 | 259 | |
| 260 | -optCoRefl :: Subst -> Coercion -> Coercion
|
|
| 260 | +optCoRefl :: Bool -> Subst -> Coercion -> Coercion
|
|
| 261 | 261 | -- See Note [optCoRefl]
|
| 262 | -optCoRefl subst in_co
|
|
| 262 | +optCoRefl check_stuff subst in_co
|
|
| 263 | 263 | | isEmptyTCvSubst subst = in_co
|
| 264 | - |
|
| 265 | - | otherwise
|
|
| 266 | -#ifndef DEBUG
|
|
| 267 | - = opt_co_refl subst in_co
|
|
| 268 | -#else
|
|
| 269 | - -- Debug check that optCoRefl doesn't change the type
|
|
| 264 | + | not check_stuff = opt_co_refl subst in_co
|
|
| 265 | + | otherwise -- Do expensive checks
|
|
| 270 | 266 | = let out_co = opt_co_refl subst in_co
|
| 271 | 267 | (Pair in_l in_r) = coercionKind in_co
|
| 272 | 268 | (Pair out_l out_r) = coercionKind out_co
|
| 273 | 269 | in_l' = substTy subst in_l
|
| 274 | 270 | in_r' = substTy subst in_r
|
| 275 | - in if (in_l' `eqType` out_l) && (in_r' `eqType` out_r)
|
|
| 276 | - then out_co
|
|
| 277 | - else pprTrace "optReflCo" (vcat [ text "in_l':" <+> ppr in_l'
|
|
| 278 | - , text "in_r':" <+> ppr in_r'
|
|
| 279 | - , text "out_l:" <+> ppr out_l
|
|
| 280 | - , text "out_r:" <+> ppr out_r
|
|
| 281 | - , text "in_co:" <+> ppr in_co
|
|
| 282 | - , text "out_co:" <+> ppr out_co ]) $
|
|
| 271 | + in_co' = substCo subst in_co
|
|
| 272 | + in_sz = coercionSize in_co'
|
|
| 273 | + out_sz = coercionSize out_co
|
|
| 274 | + in if not ((in_l' `eqType` out_l) && (in_r' `eqType` out_r))
|
|
| 275 | + then pprTrace "Yikes: optReflCo changes type"
|
|
| 276 | + (vcat [ text "in_l':" <+> ppr in_l'
|
|
| 277 | + , text "in_r':" <+> ppr in_r'
|
|
| 278 | + , text "out_l:" <+> ppr out_l
|
|
| 279 | + , text "out_r:" <+> ppr out_r
|
|
| 280 | + , text "in_co:" <+> ppr in_co
|
|
| 281 | + , text "out_co:" <+> ppr out_co ]) $
|
|
| 283 | 282 | out_co
|
| 284 | -#endif
|
|
| 285 | - |
|
| 283 | + else if out_sz < in_sz
|
|
| 284 | + then pprTrace "optCoRefl: size reduction:"
|
|
| 285 | + (vcat [ int in_sz <+> text "-->" <+> int out_sz
|
|
| 286 | + , text "in_co':" <+> ppr in_co'
|
|
| 287 | + , text "out_co:" <+> ppr out_co ]) $
|
|
| 288 | + out_co
|
|
| 289 | + else out_co
|
|
| 286 | 290 | |
| 287 | 291 | opt_co_refl :: Subst -> InCoercion -> OutCoercion
|
| 288 | 292 | opt_co_refl subst co = go co
|
| ... | ... | @@ -284,6 +284,8 @@ data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad |
| 284 | 284 | , sm_rule_opts :: !RuleOpts
|
| 285 | 285 | , sm_case_folding :: !Bool
|
| 286 | 286 | , sm_case_merge :: !Bool
|
| 287 | + , sm_opt_refl_co :: !Bool
|
|
| 288 | + , sm_check_opt_co :: !Bool
|
|
| 287 | 289 | }
|
| 288 | 290 | |
| 289 | 291 | -- | See Note [SimplPhase]
|
| ... | ... | @@ -26,7 +26,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBind |
| 26 | 26 | import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )
|
| 27 | 27 | import qualified GHC.Core.Make
|
| 28 | 28 | import GHC.Core.Coercion hiding ( substCo, substCoVar )
|
| 29 | --- import GHC.Core.Coercion.Opt
|
|
| 29 | +import GHC.Core.Coercion.Opt
|
|
| 30 | 30 | import GHC.Core.Reduction
|
| 31 | 31 | import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )
|
| 32 | 32 | import GHC.Core.DataCon
|
| ... | ... | @@ -1390,9 +1390,12 @@ simplCoercionF env co cont |
| 1390 | 1390 | |
| 1391 | 1391 | simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
|
| 1392 | 1392 | simplCoercion env co
|
| 1393 | - = do { let out_co = -- optCoRefl (getTCvSubst env) co
|
|
| 1394 | - substCo env co
|
|
| 1393 | + = do { let out_co | sm_opt_refl_co mode = optCoRefl (sm_check_opt_co mode)
|
|
| 1394 | + (getTCvSubst env) co
|
|
| 1395 | + | otherwise = substCo env co
|
|
| 1395 | 1396 | ; seqCo out_co `seq` return out_co }
|
| 1397 | + where
|
|
| 1398 | + mode = seMode env
|
|
| 1396 | 1399 | |
| 1397 | 1400 | -----------------------------------
|
| 1398 | 1401 | -- | Push a TickIt context outwards past applications and cases, as
|
| ... | ... | @@ -16,7 +16,7 @@ import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) ) |
| 16 | 16 | import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig )
|
| 17 | 17 | import GHC.Driver.Config.Core.Rules ( initRuleOpts )
|
| 18 | 18 | import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts )
|
| 19 | -import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), gopt )
|
|
| 19 | +import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), DumpFlag(..), gopt, dopt )
|
|
| 20 | 20 | |
| 21 | 21 | import GHC.Runtime.Context ( InteractiveContext(..) )
|
| 22 | 22 | |
| ... | ... | @@ -72,6 +72,8 @@ initSimplMode dflags phase name = SimplMode |
| 72 | 72 | , sm_rule_opts = initRuleOpts dflags
|
| 73 | 73 | , sm_case_folding = gopt Opt_CaseFolding dflags
|
| 74 | 74 | , sm_case_merge = gopt Opt_CaseMerge dflags
|
| 75 | + , sm_opt_refl_co = gopt Opt_OptReflCoercion dflags
|
|
| 76 | + , sm_check_opt_co = dopt Opt_D_opt_co dflags
|
|
| 75 | 77 | }
|
| 76 | 78 | |
| 77 | 79 | initGentleSimplMode :: DynFlags -> SimplMode
|
| ... | ... | @@ -1233,6 +1233,7 @@ optLevelFlags -- see Note [Documenting optimisation flags] |
| 1233 | 1233 | , ([1,2], Opt_DoCleverArgEtaExpansion) -- See Note [Eta expansion of arguments in CorePrep]
|
| 1234 | 1234 | , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0]
|
| 1235 | 1235 | , ([0,1,2], Opt_ProfManualCcs )
|
| 1236 | + , ([0,1,2], Opt_OptReflCoercion ) -- See Note [Coercion optimisation] in GHC.Core.Coercion.Opt
|
|
| 1236 | 1237 | , ([2], Opt_OptCoercion ) -- See Note [Coercion optimisation] in GHC.Core.Coercion.Opt
|
| 1237 | 1238 | , ([2], Opt_DictsStrict)
|
| 1238 | 1239 |
| ... | ... | @@ -530,6 +530,8 @@ data DumpFlag |
| 530 | 530 | | Opt_D_dump_faststrings
|
| 531 | 531 | | Opt_D_faststring_stats
|
| 532 | 532 | | Opt_D_ipe_stats
|
| 533 | + | Opt_D_opt_co -- Check the coercion optimisations,
|
|
| 534 | + -- and report ones that reduce size
|
|
| 533 | 535 | deriving (Eq, Show, Enum)
|
| 534 | 536 | |
| 535 | 537 | -- | Helper function to query whether a given `DumpFlag` is enabled or not.
|
| ... | ... | @@ -640,6 +642,7 @@ data GeneralFlag |
| 640 | 642 | | Opt_InlineGenericsAggressively
|
| 641 | 643 | | Opt_StaticArgumentTransformation
|
| 642 | 644 | | Opt_OptCoercion
|
| 645 | + | Opt_OptReflCoercion
|
|
| 643 | 646 | | Opt_CSE
|
| 644 | 647 | | Opt_StgCSE
|
| 645 | 648 | | Opt_StgLiftLams
|
| ... | ... | @@ -909,6 +912,7 @@ optimisationFlags = EnumSet.fromList |
| 909 | 912 | , Opt_StaticArgumentTransformation
|
| 910 | 913 | , Opt_PolymorphicSpecialisation
|
| 911 | 914 | , Opt_OptCoercion
|
| 915 | + , Opt_OptReflCoercion
|
|
| 912 | 916 | , Opt_CSE
|
| 913 | 917 | , Opt_StgCSE
|
| 914 | 918 | , Opt_StgLiftLams
|
| ... | ... | @@ -1657,6 +1657,8 @@ dynamic_flags_deps = [ |
| 1657 | 1657 | (NoArg $ forceRecompile >> (setVerbosity $ Just 2))
|
| 1658 | 1658 | , make_ord_flag defGhcFlag "dipe-stats"
|
| 1659 | 1659 | (setDumpFlag Opt_D_ipe_stats)
|
| 1660 | + , make_ord_flag defGhcFlag "dcheck-opt-co"
|
|
| 1661 | + (setDumpFlag Opt_D_opt_co)
|
|
| 1660 | 1662 | , make_ord_flag defGhcFlag "dfaststring-stats"
|
| 1661 | 1663 | (setDumpFlag Opt_D_faststring_stats)
|
| 1662 | 1664 | , make_ord_flag defGhcFlag "dno-llvm-mangler"
|
| ... | ... | @@ -2472,6 +2474,7 @@ fFlagsDeps = [ |
| 2472 | 2474 | flagSpec "cmm-sink" Opt_CmmSink,
|
| 2473 | 2475 | flagSpec "cmm-static-pred" Opt_CmmStaticPred,
|
| 2474 | 2476 | flagSpec "opt-coercion" Opt_OptCoercion,
|
| 2477 | + flagSpec "opt-refl-coercion" Opt_OptReflCoercion,
|
|
| 2475 | 2478 | flagSpec "cse" Opt_CSE,
|
| 2476 | 2479 | flagSpec "stg-cse" Opt_StgCSE,
|
| 2477 | 2480 | flagSpec "stg-lift-lams" Opt_StgLiftLams,
|