Simon Peyton Jones pushed to branch wip/substitution-via-mapper at Glasgow Haskell Compiler / GHC Commits: 9890c886 by Simon Peyton Jones at 2026-08-04T11:52:22+01:00 Make substitution strict It's nice that it is so easy to do so - - - - - 5 changed files: - compiler/GHC/Core/TyCo/Make.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - + compiler/GHC/Utils/StrictIdentity.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Core/TyCo/Make.hs ===================================== @@ -48,14 +48,12 @@ module GHC.Core.TyCo.Make ( -- Coercions , mkReflCo, mkNomReflCo, mkRepReflCo , mkCoVarCo, mkCoVarCos, mkHoleCo - , mkKindCo, mkSelCo + , mkKindCo , mkGReflCo, mkGReflRightCo, mkGReflLeftCo , mkGReflMCo, mkGReflRightMCo, mkGReflLeftMCo , mkSubCo, mkSymCo, mkSymMCo , mkFunCo2, mkForAllCo, mkUnivCo , mkAxiomCo, mkUnbranchedAxInstCo - , mkAppCo, mkTyConAppCo - , mkInstCo, mkLRCo , mkFunCo, mkNakedFunCo , mkNakedForAllCo, mkForAllVisCos, mkHomoForAllCo, mkHomoForAllCos , mkAxInstCo @@ -83,7 +81,7 @@ module GHC.Core.TyCo.Make ( import GHC.Prelude import {-# SOURCE #-} GHC.Core.Coercion - ( mkLRCo, mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkSelCo + ( mkLRCo, mkInstCo, mkAppCo, mkAppCos, mkSelCo , decomposePiCos , isKindCo , coercionKind -- Used in toPhantomCo @@ -222,60 +220,60 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar = (go_ty, go_tys, go_co, go_cos) where -- See Note [Use explicit recursion in mapTyCo] - go_tys !_ [] = return [] - go_tys !env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys + go_tys _ [] = return [] + go_tys env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys - go_ty !env (TyVarTy tv) = tyvar env tv - go_ty !env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 - go_ty !_ ty@(LitTy {}) = return ty - go_ty !env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co - go_ty !env (CoercionTy co) = CoercionTy <$> go_co env co + go_ty env (TyVarTy tv) = tyvar env tv + go_ty env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 + go_ty _ ty@(LitTy {}) = return ty + go_ty env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co + go_ty env (CoercionTy co) = CoercionTy <$> go_co env co - go_ty !env ty@(FunTy _ w arg res) + go_ty env ty@(FunTy _ w arg res) = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) } - go_ty !env ty@(TyConApp tc tys) + go_ty env ty@(TyConApp tc tys) = do { tys' <- go_tys env tys; tcapp_ty env ty tc tys' } - go_ty !env (ForAllTy (Bndr tv vis) inner) + go_ty env (ForAllTy (Bndr tv vis) inner) = do { tycobinder env tv vis $ \env' tv' -> do ; inner' <- go_ty env' inner ; return $ ForAllTy (Bndr tv' vis) inner' } -- See Note [Use explicit recursion in mapTyCo] - go_cos !_ [] = return [] - go_cos !env (co:cos) = (:) <$> go_co env co <*> go_cos env cos + go_cos _ [] = return [] + go_cos env (co:cos) = (:) <$> go_co env co <*> go_cos env cos - go_mco !_ MRefl = return MRefl - go_mco !env (MCo co) = MCo <$> (go_co env co) + go_mco _ MRefl = return MRefl + go_mco env (MCo co) = MCo <$> (go_co env co) go_co :: env -> Coercion -> m Coercion - go_co !env (Refl ty) = Refl <$> go_ty env ty - go_co !env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco - go_co !env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 - go_co !env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw + go_co env (Refl ty) = Refl <$> go_ty env ty + go_co env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco + go_co env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 + go_co env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw <*> go_co env c1 <*> go_co env c2 - go_co !env (CoVarCo cv) = covar env cv - go_co !env (HoleCo hole) = cohole env hole - go_co !env (UnivCo { uco_prov = p, uco_role = r - , uco_lty = t1, uco_rty = t2, uco_deps = deps }) - = mkUnivCo <$> pure p - <*> go_cos env deps - <*> pure r - <*> go_ty env t1 <*> go_ty env t2 - go_co !env (SymCo co) = mkSymCo <$> go_co env co - go_co !env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 - go_co !env (AxiomCo r cos) = mkAxiomCo r <$> go_cos env cos - go_co !env (SelCo i co) = SelCo i <$> go_co env co - go_co !env (LRCo lr co) = mkLRCo lr <$> go_co env co - go_co !env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg - go_co !env (KindCo co) = mkKindCo <$> go_co env co - go_co !env (SubCo co) = mkSubCo <$> go_co env co - go_co !env co@(TyConAppCo r tc cos) = do { cos' <- go_cos env cos + go_co env (CoVarCo cv) = covar env cv + go_co env (HoleCo hole) = cohole env hole + go_co env (UnivCo { uco_prov = p, uco_role = r + , uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = mkUnivCo <$> pure p + <*> go_cos env deps + <*> pure r + <*> go_ty env t1 <*> go_ty env t2 + go_co env (SymCo co) = mkSymCo <$> go_co env co + go_co env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 + go_co env (AxiomCo r cos) = mkAxiomCo r <$> go_cos env cos + go_co env (SelCo i co) = mkSelCo i <$> go_co env co + go_co env (LRCo lr co) = mkLRCo lr <$> go_co env co + go_co env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg + go_co env (KindCo co) = mkKindCo <$> go_co env co + go_co env (SubCo co) = mkSubCo <$> go_co env co + go_co env co@(TyConAppCo r tc cos) = do { cos' <- go_cos env cos ; tcapp_co env co r tc cos' } - go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR - , fco_kind = kind_co, fco_body = co }) + go_co env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co }) = do { kind_co' <- go_mco env kind_co ; tycobinder env tv visL $ \env' tv' -> do ; co' <- go_co env' co ===================================== compiler/GHC/Core/TyCo/Subst.hs ===================================== @@ -53,7 +53,7 @@ module GHC.Core.TyCo.Subst import GHC.Prelude -import {-# SOURCE #-} GHC.Core.Coercion ( mkCoercionType, coVarTypesRole ) +import {-# SOURCE #-} GHC.Core.Coercion ( mkCoercionType, coVarTypesRole, mkTyConAppCo ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr import {-# SOURCE #-} GHC.Core ( CoreExpr ) @@ -76,8 +76,8 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.StrictIdentity -import Data.Functor.Identity ( Identity (..) ) import Data.List (mapAccumL) {- @@ -769,8 +769,9 @@ substTheta = substTys substThetaUnchecked :: Subst -> ThetaType -> ThetaType substThetaUnchecked = substTysUnchecked - -substTyCoMapper :: TyCoMapper Subst Identity +substTyCoMapper :: TyCoMapper Subst StrictIdentity +-- Use StrictIdentity, so that the entire mapping +-- operation is strict, building no thunks substTyCoMapper = TyCoMapper { tcm_tyvar = subst_tv , tcm_covar = subst_cv @@ -787,16 +788,16 @@ substTyCoMapper tcv_bndr subst tcv _vis k = k subst' tcv' where - (subst', tcv') = substVarBndrUnchecked subst tcv + !(subst', tcv') = substVarBndrUnchecked subst tcv -- Sadly unchecked because subst_ty is used from substTyUnchecked -- Avoid allocation in this very -- common case (E.g. Int, LiftedRep etc) - tcapp_ty :: Subst -> Type -> TyCon -> [Type] -> Identity Type + tcapp_ty :: Subst -> Type -> TyCon -> [Type] -> StrictIdentity Type tcapp_ty _ ty tc tys' | null tys' = return ty | otherwise = return (mkTyConApp tc tys') - tcapp_co :: Subst -> Coercion -> Role -> TyCon -> [Coercion] -> Identity Coercion + tcapp_co :: Subst -> Coercion -> Role -> TyCon -> [Coercion] -> StrictIdentity Coercion tcapp_co _ co r tc cos' | null cos' = return co | otherwise = return (mkTyConAppCo r tc cos') @@ -807,43 +808,8 @@ subst_co :: Subst -> Coercion -> Coercion = case mapTyCoX substTyCoMapper of (ms_ty, _, ms_co, _) -> (run ms_ty, run ms_co) where - run :: forall a. (Subst -> a -> Identity a) -> Subst -> a -> a - run ms subst x = runIdentity (ms subst x) - -{- -subst_ty :: Subst -> Type -> Type --- subst_ty is the main workhorse for type substitution --- --- Note that the in_scope set is poked only if we hit a forall --- so it may often never be fully computed -subst_ty subst ty - = go ty - where - go (TyVarTy tv) = substTyVar subst tv - go (AppTy fun arg) = (mkAppTy $! (go fun)) $! (go arg) - -- The mkAppTy smart constructor is important - -- we might be replacing (a Int), represented with App - -- by [Int], represented with TyConApp - go ty@(TyConApp tc []) = tc `seq` ty -- avoid allocation in this common case - go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys - -- NB: mkTyConApp, not TyConApp. - -- mkTyConApp has optimizations. - -- See Note [Using synonyms to compress types] - -- in GHC.Core.Type - go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) - = let !mult' = go mult - !arg' = go arg - !res' = go res - in ty { ft_mult = mult', ft_arg = arg', ft_res = res' } - go (ForAllTy (Bndr tv vis) ty) - = (ForAllTy $! ((Bndr $! tv') vis)) $! (subst_ty subst' ty) - where - !(subst',tv') = substVarBndrUnchecked subst tv - -- Unchecked because subst_ty is used from substTyUnchecked - go (LitTy n) = LitTy $! n - go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) - go (CoercionTy co) = CoercionTy $! (subst_co subst co) --} + run :: forall a. (Subst -> a -> StrictIdentity a) -> Subst -> a -> a + run ms subst x = runStrictIdentity (ms subst x) substTyVar :: Subst -> TyVar -> Type substTyVar (Subst _ _ tenv _) tv @@ -885,51 +851,6 @@ substCos subst cos | isEmptyTCvSubst subst = cos | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos -{- -subst_co :: HasDebugCallStack => Subst -> Coercion -> Coercion -subst_co subst co - = go co - where - go_ty :: Type -> Type - go_ty = subst_ty subst - - go_mco :: MCoercion -> MCoercion - go_mco MRefl = MRefl - 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 (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 - 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 (CoVarCo cv) = substCoVar subst cv - go (HoleCo h) = substCoHole subst h - 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_cos cos = let cos' = map go cos - in cos' `seqList` cos' --} - -- | Perform a substitution within a 'DVarSet' of free variables, -- returning the free coercion variables. substDCoVarSet :: Subst -> DCoVarSet -> DCoVarSet ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -256,13 +256,13 @@ import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.FastString +import GHC.Utils.StrictIdentity +import GHC.Data.FastString import GHC.Data.Maybe ( orElse, isJust ) import GHC.List (build) import qualified Data.Monoid as M -import Data.Functor.Identity -- $type_classification -- #type_classification# @@ -483,9 +483,9 @@ expandTypeSynonyms ty expandTypeSynonymsX :: Subst -> Type -> Type expandTypeSynonymsX = case mapTyCoX expandTypeSynonymMapper of - (exp_ty, _, _, _) -> \subst ty -> runIdentity (exp_ty subst ty) + (exp_ty, _, _, _) -> \subst ty -> runStrictIdentity (exp_ty subst ty) -expandTypeSynonymMapper :: TyCoMapper Subst Identity +expandTypeSynonymMapper :: TyCoMapper Subst StrictIdentity -- Just like substitution, but treat TyConApp specially expandTypeSynonymMapper = substTyCoMapper { tcm_tcapp_ty = tcapp_ty } ===================================== compiler/GHC/Utils/StrictIdentity.hs ===================================== @@ -0,0 +1,41 @@ +-- | +-- Module : GHC.Utils.StrictIdentity +-- License : BSD-style (see the file LICENSE) +-- +-- The /strict/ identity functor and monad. +-- +-- This trivial type constructor serves two purposes: +-- +-- * It can be used with functions parameterized by functor or monad classes. +-- +-- * It can be used as a base monad to which a series of monad +-- transformers may be applied to construct a composite monad. +-- Most monad transformer modules include the special case of +-- applying the transformer to 'Identity'. For example, @State s@ +-- is an abbreviation for @StateT s 'Identity'@. + +----------------------------------------------------------------------------- + +module GHC.Utils.StrictIdentity ( + StrictIdentity(..) + ) where + +import GHC.Prelude + +import Data.Coerce( coerce ) + +newtype StrictIdentity a = StrictIdentity { runStrictIdentity :: a } + +----------------------------------------------------------------------------- +-- In the following instances, the key lines are the strict applications ($!) +----------------------------------------------------------------------------- + +instance Functor StrictIdentity where + fmap f (StrictIdentity x) = StrictIdentity (f $! x) + +instance Applicative StrictIdentity where + pure = StrictIdentity + (StrictIdentity f) <*> (StrictIdentity x) = StrictIdentity (f $! x) + +instance Monad StrictIdentity where + m >>= k = k $! (runStrictIdentity m) ===================================== compiler/ghc.cabal.in ===================================== @@ -1029,6 +1029,7 @@ Library GHC.Utils.Panic.Plain GHC.Utils.Ppr GHC.Utils.Ppr.Colour + GHC.Utils.StrictIdentity GHC.Utils.TmpFs GHC.Utils.Touch GHC.Utils.Trace View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9890c886344f28b32af722675efb64a6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9890c886344f28b32af722675efb64a6... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help