Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 1aac7095 by sheaf at 2026-08-16T04:37:16-04:00 Avoid wasteful allocations in mkTyConAppCo The idiom "traverse isReflCo_maybe" followed by "map fst" used in 'GHC.Core.Coercion.mkTyConAppCo' was allocating a lot of waste. This commit uses 'GHC.Data.Unboxed.traverseMaybeUB' to avoid all these unnecessary intermediate allocations. In a quick microbenchmark for 'mkTyConAppCo', this change resulted in: - refl case (all argument coercions are reflexive): - -60% runtime - -80% allocations - non-refl case: - from 0% to -12% runtime (depending on which argument is non-refl) - from 0% to -70% allocations ( -- '' -- ) Fixes #27648 ------------------------- Metric Decrease: FamAppCachePerf SimplCastPerf T12425 T15703 T26426 T3064 T9872a T9872b T9872b_defer T9872c T9872d T5321Fun T9020 T9630 TcPlugin_RewritePerf Metric Increase: LinkableUsage02 ------------------------- - - - - - 3 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Data/Unboxed.hs - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -147,6 +147,7 @@ import GHC.Types.Basic import GHC.Types.Unique import GHC.Data.FastString import GHC.Data.Pair +import GHC.Data.Unboxed (traverseMaybeUB) import GHC.Types.SrcLoc import GHC.Builtin.KnownKeys import GHC.Builtin.WiredIn.Prim @@ -166,6 +167,7 @@ import Data.Char( isDigit ) import qualified Data.Monoid as Monoid import Data.List.NonEmpty ( NonEmpty (..) ) import Control.DeepSeq +import GHC.Exts (inline) {- %************************************************************************ @@ -722,6 +724,19 @@ isReflexiveCo_maybe co = Nothing where (Pair ty1 ty2, r) = coercionKindRole co +-- | Like @\\ cos -> map fst <$> traverse isReflCo_maybe cos@, +-- but avoiding wasteful allocations (see #27648). +reflCos_maybe :: [Coercion] -> Maybe [Type] +reflCos_maybe = + traverseMaybeUB + ( fmap fst + . inline isReflCo_maybe + -- isReflCo_maybe must inline so that 'fmap fst' fuses and the whole + -- function inlines into 'traverseMaybeUB' + ) +{-# INLINE reflCos_maybe #-} + -- to avoid allocating the result's 'Just' constructor application + forAllCoKindCo :: TyCoVar -> KindMCoercion -> KindCoercion -- Get the kind coercion from a ForAllCo forAllCoKindCo _ (MCo co) = co @@ -811,8 +826,8 @@ mkTyConAppCo r tc cos | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos - | Just tys_roles <- traverse isReflCo_maybe cos - = mkReflCo r (mkTyConApp tc (map fst tys_roles)) + | Just tys <- reflCos_maybe cos + = mkReflCo r $! mkTyConApp tc tys -- See Note [Refl invariant] | otherwise = TyConAppCo r tc cos ===================================== compiler/GHC/Data/Unboxed.hs ===================================== @@ -13,10 +13,11 @@ module GHC.Data.Unboxed ( MaybeUB(JustUB, NothingUB), - fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB + fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB, + traverseMaybeUB ) where -import GHC.Prelude hiding (Maybe(..), Either(..)) +import GHC.Prelude -- | Like Maybe, but using unboxed sums. -- @@ -54,3 +55,28 @@ fmapMaybeUB f (JustUB x) = JustUB $ f x maybeUB :: b -> (a -> b) -> MaybeUB a -> b maybeUB _def f (JustUB x) = f x maybeUB def _f NothingUB = def + +toMaybe :: MaybeUB a -> Maybe a +toMaybe NothingUB = Nothing +toMaybe (JustUB a) = Just a + +-- | Like 'traverse' for the 'Maybe' applicative, but avoiding intermediate +-- allocations. +-- +-- The passed-in function must inline for this to help at all. +traverseMaybeUB + :: forall a b + . (a -> Maybe b) -- ^ @INLINE@ function to map over the list + -> [a] -> Maybe [b] +{-# INLINE traverseMaybeUB #-} + -- 'traverseMaybeUB' must inline so that the function it is passed can inline +traverseMaybeUB f = \ xs -> toMaybe $ go xs + where + go :: [a] -> MaybeUB [b] + go [] = JustUB [] + go (a:as) + | Just b <- f a -- f is assumed to inline + , JustUB bs <- go as + = JustUB (b:bs) + | otherwise + = NothingUB ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -86,6 +86,7 @@ GHC.Data.Pair GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap +GHC.Data.Unboxed GHC.Data.Word64Map GHC.Data.Word64Map.Internal GHC.Data.Word64Map.Lazy View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1aac70958f3774332131b22a948f3785... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1aac70958f3774332131b22a948f3785... 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