Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: e180c6dc by Simon Peyton Jones at 2026-01-14T09:07:38+00:00 Fuse optCoRefl and substCo Maybe this will be better than either - - - - - 4 changed files: - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Utils/Misc.hs Changes: ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -257,12 +257,17 @@ optCoAlt is (Alt k bs e) left-to-right, and won't spot (co1 ; co2 ; sym co2) -} -optCoRefl :: Coercion -> Coercion +optCoRefl :: Subst -> Coercion -> Coercion -- See Note [optCoRefl] -optCoRefl in_co -#ifdef DEBUG +optCoRefl 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 - = let out_co = go in_co + = 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 if (in_l `eqType` out_l) && (in_r `eqType` out_r) @@ -274,9 +279,11 @@ optCoRefl in_co , text "in_co:" <+> ppr in_co , text "out_co:" <+> ppr out_co ]) $ out_co -#else - = go in_co #endif + + +opt_co_refl :: Subst -> Coercion -> Coercion +opt_co_refl subst co = go co where go_m MRefl = MRefl go_m (MCo co) = MCo (go co) @@ -294,12 +301,17 @@ optCoRefl in_co go (LRCo n co) = mkLRCo n (go co) go (AppCo co1 co2) = mkAppCo (go co1) (go co2) go (InstCo co1 co2) = mkInstCo (go co1) (go co2) - go (ForAllCo v vl vr mco co) = mkForAllCo v vl vr (go_m mco) (go co) go (FunCo r afl afr com coa cor) = mkFunCo2 r afl afr (go com) (go coa) (go cor) go (TyConAppCo r tc cos) = mkTyConAppCo r tc (go_s cos) go (UnivCo p r lt rt cos) = mkUnivCo p (go_s cos) r lt rt go (AxiomCo ax cos) = mkAxiomCo ax (go_s cos) + go (ForAllCo v vl vr mco co) = mkForAllCo v' vl vr + $!! go_m mco + $!! opt_co_refl subst' co + where + !(subst', v') = substVarBndr subst v + -- This is the main payload go (TransCo co1 co2) = gobble gs0 co1 [co2] where ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1390,7 +1390,7 @@ simplCoercionF env co cont simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co - = do { let out_co = optCoRefl (substCo env co) + = do { let out_co = optCoRefl (getTCvSubst env) co ; seqCo out_co `seq` return out_co } ----------------------------------- ===================================== compiler/GHC/Core/TyCo/Subst.hs ===================================== @@ -860,33 +860,33 @@ subst_co subst co go_mco (MCo co) = MCo (go co) go :: Coercion -> Coercion - go (Refl ty) = mkNomReflCo $! (go_ty ty) - go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) - go (TyConAppCo r tc args)= mkTyConAppCo r tc $! go_cos args - go (AxiomCo con cos) = mkAxiomCo con $! go_cos cos - go (AppCo co arg) = (mkAppCo $! go co) $! go arg + go (Refl ty) = mkNomReflCo $!! go_ty ty + go (GRefl r ty mco) = mkGReflCo r $!! go_ty ty $!! go_mco mco + go (TyConAppCo r tc args)= mkTyConAppCo r tc $!! go_cos args + go (AxiomCo con cos) = mkAxiomCo con $!! go_cos cos + go (AppCo co arg) = mkAppCo $!! go co $!! go arg go (ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR , fco_kind = kind_co, fco_body = co }) - = ((mkForAllCo $! tcv') visL visR - $! go_mco kind_co) - $! subst_co subst' co + = (mkForAllCo $!! tcv') visL visR + $!! go_mco kind_co + $!! subst_co subst' co where !(subst', tcv') = substVarBndrUnchecked subst tcv -- Unchecked because used from substTyUnchecked - go (FunCo r afl afr w co1 co2) = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2 + go (FunCo r afl afr w co1 co2) = mkFunCo2 r afl afr $!! go w $!! go co1 $!! go co2 go (CoVarCo cv) = substCoVar subst cv go (UnivCo { uco_prov = p, uco_role = r , uco_lty = t1, uco_rty = t2, uco_deps = deps }) - = ((((mkUnivCo $! p) $! go_cos deps) $! r) $! - (go_ty t1)) $! (go_ty t2) - go (SymCo co) = mkSymCo $! (go co) - go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) - go (SelCo d co) = mkSelCo d $! (go co) - go (LRCo lr co) = mkLRCo lr $! (go co) - go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg - go (KindCo co) = mkKindCo $! (go co) - go (SubCo co) = mkSubCo $! (go co) - go (HoleCo h) = HoleCo $! go_hole h + = mkUnivCo p $!! go_cos deps $!! r + $!! go_ty t1 $!! go_ty t2 + go (SymCo co) = mkSymCo $!! go co + go (TransCo co1 co2) = mkTransCo $!! go co1 $!! go co2 + go (SelCo d co) = mkSelCo d $!! go co + go (LRCo lr co) = mkLRCo lr $!! go co + go (InstCo co arg) = mkInstCo $!! go co $!! go arg + go (KindCo co) = mkKindCo $!! go co + go (SubCo co) = mkSubCo $!! go co + go (HoleCo h) = HoleCo $!! go_hole h go_cos cos = let cos' = map go cos in cos' `seqList` cos' ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -8,7 +8,7 @@ -- module GHC.Utils.Misc ( -- * Miscellaneous higher-order functions - applyWhen, nTimes, const2, + applyWhen, nTimes, const2, ($!!), -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, @@ -44,8 +44,7 @@ module GHC.Utils.Misc ( mergeListsBy, isSortedBy, - -- Foldable generalised functions, - + -- * Foldable generalised functions, mapMaybe', -- * Tuples @@ -153,6 +152,8 @@ import qualified Data.Set as Set import Data.Time +infixl 0 $!! -- LEFT associative + {- ************************************************************************ * * @@ -199,6 +200,14 @@ third3 f (a, b, c) = (a, b, f c) uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c +($!!) :: forall r a (b :: TYPE r). (a -> b) -> a -> b +-- | ^ ($!!) is left-associative so you can write +-- (f $!! e1 $!! e2) for a multi-argument strict application +-- In contrast ($) and ($!) are right associative +{-# INLINE ($!!) #-} +f $!! x = let !vx = x in f vx -- see #2273 + + {- ************************************************************************ * * View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e180c6dc8f8141c31771b50d30c17c4c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e180c6dc8f8141c31771b50d30c17c4c... You're receiving this email because of your account on gitlab.haskell.org.