Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 52c7e75f by Simon Peyton Jones at 2026-01-20T17:47:22+00:00 Care with the simple refl optimiser [skip ci] - - - - - 5 changed files: - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Driver/Config.hs - compiler/GHC/Driver/Config/Core/Lint.hs Changes: ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -300,8 +300,13 @@ optCoRefl check_stuff subst in_co out_co opt_co_refl :: Subst -> InCoercion -> OutCoercion -opt_co_refl subst co = go co +opt_co_refl subst co + | lk `eqTypeIgnoringMultiplicity` rk = mkReflCo (coercionRole co) lk + | otherwise = out_co where + out_co = go co + Pair lk rk = coercionKind out_co + go_m MRefl = MRefl go_m (MCo co) = MCo (go co) @@ -339,14 +344,25 @@ opt_co_refl subst co = go co where !(subst', v') = substVarBndr subst v - -- This is the main payload - go (TransCo co1 co2) = gobble gs0 co1 [co2] + -- The TransCo case fires up the main loop for + -- eliminating reflexive chains of TransCo + go (TransCo co1 co2) + | lk' `eqTypeIgnoringMultiplicity` rk' = go co2 + | otherwise = gobble0 gs1 [co2] where - lk' = substTy subst (coercionLKind co1) + co1' = go co1 + Pair lk' rk' = coercionKind co1 role = coercionRole co1 - gs0 :: GobbleState - gs0 = GS (mkReflCo role lk') (insertTM lk' gs0 emptyTM) + gs0, gs1 :: GobbleState + gs0 = GS (mkReflCo role lk') tm0 + gs1 = GS co1' (insertTM rk' gs1 tm0) + + tm0 = insertTM lk' gs0 emptyTM + + gobble0 :: GobbleState -> [InCoercion] -> OutCoercion + gobble0 (GS co _) [] = co + gobble0 gs (co:cos) = gobble gs co cos gobble :: GobbleState -> InCoercion -> [InCoercion] -> OutCoercion -- gobble (GS co1 tm) co2 cos returns a coercion equivalent to (co1;co2;cos) @@ -361,8 +377,6 @@ opt_co_refl subst co = go co rk' = coercionRKind co2' gs' = GS (co1' `mkTransCo` co2') (insertTM rk' gs' tm) - gobble0 (GS co _) [] = co - gobble0 gs (co:cos) = gobble gs co cos data GobbleState = GS OutCoercion (TypeMap GobbleState) -- The map is keyed by OutType ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -26,6 +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 qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion.Opt import GHC.Core.Reduction import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) @@ -1391,19 +1392,20 @@ simplCoercionF env co cont simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co = do { let out_co | sm_opt_refl_co mode - , not (isEmptyTCvSubst subst) || initial_phase - = optCoRefl (sm_check_opt_co mode) subst co - | otherwise - = substCo env co - subst = getTCvSubst env - initial_phase = case sePhase env of - SimplPhase InitialPhase -> True - _ -> False + = if isEmptyTCvSubst subst + then co + else optCoRefl chk_opts subst co + | otherwise -- substCo also has a shortcut + -- when substitution is empty + = Coercion.substCo subst co ; seqCo out_co `seq` return out_co } where - mode = seMode env + mode = seMode env + chk_opts = sm_check_opt_co mode + subst = getTCvSubst env + ----------------------------------- -- | Push a TickIt context outwards past applications and cases, as ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -34,6 +34,7 @@ import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSub , isInScope, substTyVarBndr, cloneTyVarBndr ) import GHC.Core.Predicate( isCoVarType ) import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.Coercion.Opt( optCoRefl ) import GHC.Types.Literal import GHC.Types.Id @@ -115,14 +116,18 @@ data SimpleOpts = SimpleOpts , so_eta_red :: !Bool -- ^ Eta reduction on? , so_inline :: !Bool -- ^ False <=> do no inlining whatsoever, -- even for trivial or used-once things + , so_opt_co :: !Bool -- ^ Run the simple `optCoRefl` optimiser on coercions + , so_check_opt_co :: !Bool -- ^ Do debug-checking for `optCoRefl` } -- | Default options for the Simple optimiser. defaultSimpleOpts :: SimpleOpts defaultSimpleOpts = SimpleOpts - { so_uf_opts = defaultUnfoldingOpts - , so_eta_red = False - , so_inline = True + { so_uf_opts = defaultUnfoldingOpts + , so_eta_red = False + , so_inline = True + , so_opt_co = True + , so_check_opt_co = False } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr @@ -327,19 +332,15 @@ simple_opt_expr env expr = go expr (env', bndrs') = subst_opt_bndrs env bndrs simple_opt_co :: SimpleOptEnv -> InCoercion -> OutCoercion -simple_opt_co env co = substCo (soe_subst env) co - -mk_cast :: CoreExpr -> CoercionR -> CoreExpr --- Like GHC.Core.Utils.mkCast, but does a full reflexivity check. --- mkCast doesn't do that because the Simplifier does (in simplCast) --- But in SimpleOpt it's nice to kill those nested casts (#18112) -mk_cast (Cast e co1) co2 = mk_cast e (co1 `mkTransCo` co2) -mk_cast (Tick t e) co = Tick t (mk_cast e co) -mk_cast e co - | isReflexiveCo co - = e - | otherwise - = Cast e co +-- Optimise a coercion, optionally running +-- the simple `optCoRefl` optimiser +-- If (so_opt_co opts) is on, we run the optimiser even if the substition +-- is empty, to kill off Refls; but if not, `substCo` does a no-op if +-- the substitution is empty +simple_opt_co (SOE { soe_subst = subst, soe_opts = opts }) co + | so_opt_co opts = optCoRefl (so_check_opt_co opts) subst co + | otherwise = substCo subst co + ---------------------- -- simple_app collects arguments for beta reduction @@ -406,8 +407,8 @@ simple_app env e0@(Lam {}) as0@(_:_) | otherwise = rebuild_app env (simple_opt_expr env e) as - do_beta env (Cast e co) as = - do_beta env e (add_cast env co as) + do_beta env (Cast e co) as + = do_beta env e (add_cast env co as) do_beta env body as = simple_app env body as @@ -478,7 +479,7 @@ rebuild_app env fun args = foldl mk_app fun args in_scope = soeInScope env mk_app out_fun = \case ApplyToArg arg -> App out_fun (simple_opt_clo in_scope arg) - CastIt co -> mk_cast out_fun co + CastIt co -> mkCast out_fun co {- Note [Desugaring unlifted newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -18,6 +18,8 @@ initSimpleOpts dflags = SimpleOpts { so_uf_opts = unfoldingOpts dflags , so_eta_red = gopt Opt_DoEtaReduction dflags , so_inline = True + , so_opt_co = gopt Opt_OptReflCoercion dflags + , so_check_opt_co = dopt Opt_D_opt_co dflags } -- | Instruct the interpreter evaluation to break... ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -153,7 +153,7 @@ perPassFlags dflags pass -- `-dlinear-core-lint`: check linearity in every pass || -- Always check linearity just after desugaring case pass of - CoreDesugar -> True + CoreDesugar -> True -- Before even the simple optimiser _ -> False -- See Note [Checking for rubbish literals] in GHC.Core.Lint View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52c7e75ff7e5de8bec9681ca0dc40638... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52c7e75ff7e5de8bec9681ca0dc40638... You're receiving this email because of your account on gitlab.haskell.org.