From 829609bde5eb0725c5bb80fbf6543811d5531123 Mon Sep 17 00:00:00 2001 From: Andreas Klebinger Date: Wed, 21 Sep 2022 02:37:43 +0200 Subject: Apply some tricks to speed up core lint. Below are the noteworthy changes and if given their impact on compiler allocations for a type heavy module: * Use the oneShot trick on LintM * Use a unboxed tuple for the result of LintM: ~6% reduction * Avoid a thunk for the result of typeKind in lintType: ~5% reduction * lint_app: Don't allocate the error msg in the hot code path: ~4% reduction * lint_app: Eagerly force the in scope set: ~4% * nonDetCmpType: Try to short cut using reallyUnsafePtrEquality#: ~2% * lintM: Use a unboxed maybe for the `a` result: ~12% * lint_app: make go_app tail recursive to avoid allocating the go function as heap closure: ~7% * expandSynTyCon_maybe: Use a specialized data type For a less type heavy module like nofib/spectral/simple compiled with -O -dcore-lint allocations went down by ~24% and compile time by ~9%. ------------------------- Metric Decrease: T1969 ------------------------- --- compiler/GHC/Core/Coercion.hs | 2 +- compiler/GHC/Core/FamInstEnv.hs | 2 +- compiler/GHC/Core/Lint.hs | 181 ++++++++++++++++------ compiler/GHC/Core/TyCon.hs | 19 ++- compiler/GHC/Core/Type.hs | 23 ++- compiler/GHC/Data/Unboxed.hs | 50 ++++++ compiler/ghc.cabal.in | 1 + testsuite/tests/count-deps/CountDepsAst.stdout | 1 + testsuite/tests/count-deps/CountDepsParser.stdout | 1 + 9 files changed, 221 insertions(+), 59 deletions(-) create mode 100644 compiler/GHC/Data/Unboxed.hs diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index cab154aa5c..8a13ecb51b 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -781,7 +781,7 @@ mkTyConAppCo r tc cos mkFunCo r w co1 co2 -- Expand type synonyms - | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe 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 diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index d59376622f..844f753957 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -1370,7 +1370,7 @@ normaliseTcApp env role tc tys -- See Note [Normalising types] about the LiftingContext normalise_tc_app :: TyCon -> [Type] -> NormM Reduction normalise_tc_app tc tys - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys , not (isFamFreeTyCon tc) -- Expand and try again = -- A synonym with type families in the RHS -- Expand and try again diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index a9d01787fd..04f685de55 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnboxedSums #-} {- (c) The University of Glasgow 2006 @@ -95,6 +97,8 @@ import Data.List.NonEmpty ( NonEmpty(..), groupWith ) import Data.List ( partition ) import Data.Maybe import GHC.Data.Pair +import GHC.Base (oneShot) +import GHC.Data.Unboxed {- Note [Core Lint guarantee] @@ -263,6 +267,42 @@ case, however, we set le_joins to empty, and catch the error. Similarly, join points can occur free in RHSes of other join points but not the RHSes of value bindings (thunks and functions). +Note [Avoiding compiler perf traps when constructing error messages.] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's quite common to put error messages into a where clause when it might +be triggered by multiple branches. E.g. + + checkThing x y z = + case x of + X -> unless (correctX x) $ failWithL errMsg + Y -> unless (correctY y) $ failWithL errMsg + where + errMsg = text "My error involving:" $$ ppr x <+> ppr y + +However ghc will compile this to: + + checkThink x y z = + let errMsg = text "My error involving:" $$ ppr x <+> ppr y + in case x of + X -> unless (correctX x) $ failWithL errMsg + Y -> unless (correctY y) $ failWithL errMsg + +Putting the allocation of errMsg into the common non-error path. +One way to work around this is to turn errMsg into a function: + + checkThink x y z = + case x of + X -> unless (correctX x) $ failWithL (errMsg x y) + Y -> unless (correctY y) $ failWithL (errMsg x y) + where + errMsg x y = text "My error involving:" $$ ppr x <+> ppr y + +This way `errMsg` is a static function and it being defined in the common +path does not result in allocation in the hot path. This can be surprisingly +impactful. Changing `lint_app` reduced allocations for one test program I was +looking at by ~4%. + + ************************************************************************ * * Beginning and ending passes @@ -1825,7 +1865,7 @@ lintTySynFamApp report_unsat ty tc tys = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) -- Deal with type synonyms - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' = do { -- Kind-check the argument types, but without reporting -- un-saturated type families/synonyms @@ -1874,13 +1914,15 @@ lintArrow what t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw ----------------- lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM () -lint_ty_app ty k tys - = lint_app (text "type" <+> quotes (ppr ty)) k tys +lint_ty_app msg_ty k tys + -- See Note [Avoiding compiler perf traps when constructing error messages.] + = lint_app (\msg_ty -> text "type" <+> quotes (ppr msg_ty)) msg_ty k tys ---------------- lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM () -lint_co_app ty k tys - = lint_app (text "coercion" <+> quotes (ppr ty)) k tys +lint_co_app msg_ty k tys + -- See Note [Avoiding compiler perf traps when constructing error messages.] + = lint_app (\msg_ty -> text "coercion" <+> quotes (ppr msg_ty)) msg_ty k tys ---------------- lintTyLit :: TyLit -> LintM () @@ -1891,46 +1933,62 @@ lintTyLit (NumTyLit n) lintTyLit (StrTyLit _) = return () lintTyLit (CharTyLit _) = return () -lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM () +lint_app :: Outputable msg_thing => (msg_thing -> SDoc) -> msg_thing -> LintedKind -> [LintedType] -> LintM () -- (lint_app d fun_kind arg_tys) -- We have an application (f arg_ty1 .. arg_tyn), -- where f :: fun_kind -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lint_app doc kfn arg_tys - = do { in_scope <- getInScope +-- +-- Being strict in the kind here avoids quite a few pointless thunks +-- reducing allocations by ~5% +lint_app mk_msg msg_type !kfn arg_tys + = do { !in_scope <- getInScope -- We need the in_scope set to satisfy the invariant in -- Note [The substitution invariant] in GHC.Core.TyCo.Subst - ; _ <- foldlM (go_app in_scope) kfn arg_tys - ; return () } + -- Forcing the in scope set eagerly here reduces allocations by up to 4%. + ; go_app in_scope kfn arg_tys + } where - fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc - , nest 2 (text "Function kind =" <+> ppr kfn) - , nest 2 (text "Arg types =" <+> ppr arg_tys) - , extra ] - go_app in_scope kfn ta + -- We use explicit recursion instead of a fold here to avoid go_app becoming + -- an allocated function closure. This reduced allocations by up to 7% for some + -- modules. + go_app :: InScopeSet -> LintedKind -> [Type] -> LintM () + go_app !in_scope !kfn ta | Just kfn' <- coreView kfn = go_app in_scope kfn' ta - go_app _ fun_kind@(FunTy _ _ kfa kfb) ta + go_app _in_scope _kind [] = return () + + go_app in_scope fun_kind@(FunTy _ _ kfa kfb) (ta:tas) = do { let ka = typeKind ta ; unless (ka `eqType` kfa) $ - addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) - ; return kfb } + addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) + ; go_app in_scope kfb tas } - go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta + go_app in_scope (ForAllTy (Bndr kv _vis) kfn) (ta:tas) = do { let kv_kind = varType kv ka = typeKind ta ; unless (ka `eqType` kv_kind) $ - addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ + addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr ta <+> dcolon <+> ppr ka))) - ; return $ substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn } + ; let kind' = substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn + ; go_app in_scope kind' tas } go_app _ kfn ta - = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) - + = failWithL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) + +-- This is a top level definition to ensure we pass all variables of the error message +-- explicitly and don't capture them as free variables. Otherwise this binder might +-- become a thunk that get's allocated in the hot code path. +-- See Note [Avoiding compiler perf traps when constructing error messages.] +lint_app_fail_msg :: (Outputable a1, Outputable a2) => a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc +lint_app_fail_msg kfn arg_tys mk_msg msg_type extra = vcat [ hang (text "Kind application error in") 2 (mk_msg msg_type) + , nest 2 (text "Function kind =" <+> ppr kfn) + , nest 2 (text "Arg types =" <+> ppr arg_tys) + , extra ] {- ********************************************************************* * * Linting rules @@ -2672,14 +2730,41 @@ data StaticPtrCheck deriving Eq newtype LintM a = - LintM { unLintM :: + LintM' { unLintM :: LintEnv -> WarnsAndErrs -> -- Warning and error messages so far - (Maybe a, WarnsAndErrs) } -- Result and messages (if any) - deriving (Functor) + LResult a } -- Result and messages (if any) + + +pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern LintM m <- LintM' m + where + LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we) + -- LintM m = LintM' (oneShot $ oneShot m) +{-# COMPLETE LintM #-} + +instance Functor (LintM) where + fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w) type WarnsAndErrs = (Bag SDoc, Bag SDoc) +-- Using a unboxed tuple here reduced allocations for a lint heavy +-- file by ~6%. Using MaybeUB reduced them further by another ~12%. +type LResult a = (# MaybeUB a, WarnsAndErrs #) + +pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a +pattern LResult m w = (# m, w #) +{-# COMPLETE LResult #-} + +mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2 +mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w + +-- Just for testing. +fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a +fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs +fromBoxedLResult (Nothing,errs) = LResult NothingUB errs + {- Note [Checking for global Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before CoreTidy, all locally-bound Ids must be LocalIds, even @@ -2804,21 +2889,27 @@ Wrinkle 2: 'hasNoBinding' and laziness -} instance Applicative LintM where - pure x = LintM $ \ _ errs -> (Just x, errs) + pure x = LintM $ \ _ errs -> LResult (JustUB x) errs + --(Just x, errs) (<*>) = ap instance Monad LintM where m >>= k = LintM (\ env errs -> - let (res, errs') = unLintM m env errs in + let res = unLintM m env errs in case res of - Just r -> unLintM (k r) env errs' - Nothing -> (Nothing, errs')) + LResult (JustUB r) errs' -> unLintM (k r) env errs' + LResult NothingUB errs' -> LResult NothingUB errs' + ) + -- LError errs'-> LError errs') + -- let (res, errs') = unLintM m env errs in + -- Just r -> unLintM (k r) env errs' + -- Nothing -> (Nothing, errs')) instance MonadFail LintM where fail err = failWithL (text err) getPlatform :: LintM Platform -getPlatform = LintM (\ e errs -> (Just (le_platform e), errs)) +getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs)) data LintLocInfo = RhsOf Id -- The variable bound @@ -2851,9 +2942,9 @@ initL :: LintConfig -> WarnsAndErrs initL cfg m = case unLintM m env (emptyBag, emptyBag) of - (Just _, errs) -> errs - (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs - | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ + LResult (JustUB _) errs -> errs + LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs + | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ "without reporting an error message") empty where (tcvs, ids) = partition isTyCoVar $ l_vars cfg @@ -2882,7 +2973,7 @@ noFixedRuntimeRepChecks thing_inside in unLintM thing_inside env' errs getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) +getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs) checkL :: Bool -> SDoc -> LintM () checkL True _ = return () @@ -2898,15 +2989,15 @@ checkWarnL False msg = addWarnL msg failWithL :: SDoc -> LintM a failWithL msg = LintM $ \ env (warns,errs) -> - (Nothing, (warns, addMsg True env errs msg)) + fromBoxedLResult (Nothing, (warns, addMsg True env errs msg)) addErrL :: SDoc -> LintM () addErrL msg = LintM $ \ env (warns,errs) -> - (Just (), (warns, addMsg True env errs msg)) + fromBoxedLResult (Just (), (warns, addMsg True env errs msg)) addWarnL :: SDoc -> LintM () addWarnL msg = LintM $ \ env (warns,errs) -> - (Just (), (addMsg False env warns msg, errs)) + fromBoxedLResult (Just (), (addMsg False env warns msg, errs)) addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc addMsg is_error env msgs msg @@ -2938,7 +3029,7 @@ addLoc extra_loc m unLintM m (env { le_loc = extra_loc : le_loc env }) errs inCasePat :: LintM Bool -- A slight hack; see the unique call site -inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) +inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs) where is_case_pat (LE { le_loc = CasePat {} : _ }) = True is_case_pat _other = False @@ -2954,7 +3045,7 @@ addInScopeId id linted_ty m | otherwise = delVarSet join_set id -- Remove any existing binding getInScopeIds :: LintM (VarEnv (Id,LintedType)) -getInScopeIds = LintM (\env errs -> (Just (le_ids env), errs)) +getInScopeIds = LintM (\env errs -> fromBoxedLResult (Just (le_ids env), errs)) extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a extendTvSubstL tv ty m @@ -2974,16 +3065,16 @@ markAllJoinsBadIf True m = markAllJoinsBad m markAllJoinsBadIf False m = m getValidJoins :: LintM IdSet -getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) +getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs)) getSubst :: LintM Subst -getSubst = LintM (\ env errs -> (Just (le_subst env), errs)) +getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs)) getUEAliases :: LintM (NameEnv UsageEnv) -getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs)) +getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs)) getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> (Just (getSubstInScope $ le_subst env), errs)) +getInScope = LintM (\ env errs -> fromBoxedLResult (Just (getSubstInScope $ le_subst env), errs)) lookupIdInScope :: Id -> LintM (Id, LintedType) lookupIdInScope id_occ diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 54672ab80d..5ae1e2bf6b 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -108,6 +108,7 @@ module GHC.Core.TyCon( mkTyConTagMap, -- ** Manipulating TyCons + ExpandSynResult(..), expandSynTyCon_maybe, newTyConCo, newTyConCo_maybe, pprPromotionQuote, mkTyConKind, @@ -2521,12 +2522,14 @@ isConcreteTyConFlavour = \case ----------------------------------------------- -} +data ExpandSynResult tyco + = NoExpansion + | ExpandsSyn [(TyVar,tyco)] Type [tyco] + expandSynTyCon_maybe :: TyCon -> [tyco] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,tyco)], - Type, - [tyco]) -- ^ Returns a 'TyVar' substitution, the body + -> ExpandSynResult tyco -- ^ Returns a 'TyVar' substitution, the body -- type of the synonym (not yet substituted) -- and any arguments remaining from the -- application @@ -2536,13 +2539,13 @@ expandSynTyCon_maybe expandSynTyCon_maybe tc tys | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc = if arity == 0 - then Just ([], rhs, tys) -- Avoid a bit of work in the case of nullary synonyms + then ExpandsSyn [] rhs tys -- Avoid a bit of work in the case of nullary synonyms else case tys `listLengthCmp` arity of - GT -> Just (tvs `zip` tys, rhs, drop arity tys) - EQ -> Just (tvs `zip` tys, rhs, []) - LT -> Nothing + GT -> ExpandsSyn (tvs `zip` tys) rhs (drop arity tys) + EQ -> ExpandsSyn (tvs `zip` tys) rhs [] + LT -> NoExpansion | otherwise - = Nothing + = NoExpansion ---------------- diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 17519d8dd5..8d41466d30 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -4,6 +4,7 @@ -- Type - public interface {-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -294,10 +295,10 @@ import GHC.Data.Pair import GHC.Data.List.SetOps import GHC.Types.Unique ( nonDetCmpUnique ) +import GHC.Base (reallyUnsafePtrEquality#) import GHC.Data.Maybe ( orElse, expectJust, isJust ) import Control.Monad ( guard ) import qualified Data.Semigroup as S --- import GHC.Utils.Trace -- $type_classification -- #type_classification# @@ -556,7 +557,7 @@ expandTypeSynonyms ty in_scope = mkInScopeSet (tyCoVarsOfType ty) go subst (TyConApp tc tys) - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc expanded_tys = let subst' = mkTvSubst in_scope (mkVarEnv tenv) -- Make a fresh substitution; rhs has nothing to -- do with anything that has happened so far @@ -2787,6 +2788,16 @@ comparing type variables is nondeterministic, note the call to nonDetCmpVar in nonDetCmpTypeX. See Note [Unique Determinism] for more details. +Note [Type comparisons using object pointer comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Quite often we substitute the type from a definition site into +occurances without a change. This means for code like: + \x -> (x,x,x) +The type of every `x` will often be represented by a single object +in the heap. We can take advantage of this by shortcutting the equality +check if two types are represented by the same pointer under the hood. +In some cases this reduces compiler allocations by ~2%. + Note [Computing equality on types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are several places within GHC that depend on the precise choice of @@ -2800,11 +2811,15 @@ See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. -} nonDetCmpType :: Type -> Type -> Ordering +nonDetCmpType !t1 !t2 + -- See Note [Type comparisons using object pointer comparisons] + | 1# <- reallyUnsafePtrEquality# t1 t2 + = EQ nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = EQ -nonDetCmpType t1 t2 +nonDetCmpType t1 t2 = -- we know k1 and k2 have the same kind, because they both have kind *. - = nonDetCmpTypeX rn_env t1 t2 + nonDetCmpTypeX rn_env t1 t2 where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) {-# INLINE nonDetCmpType #-} diff --git a/compiler/GHC/Data/Unboxed.hs b/compiler/GHC/Data/Unboxed.hs new file mode 100644 index 0000000000..dbd197351b --- /dev/null +++ b/compiler/GHC/Data/Unboxed.hs @@ -0,0 +1,50 @@ +-- Unboxed counterparts to data structures + +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnliftedNewtypes #-} + +module GHC.Data.Unboxed ( + MaybeUB(JustUB, NothingUB), + fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB + ) where + +import GHC.Prelude hiding (Maybe(..), Either(..)) + +-- | Like Maybe, but using unboxed sums. +-- +-- Use with care. Using a unboxed maybe is not always a win +-- in execution *time* even when allocations go down. So make +-- sure to benchmark for execution time as well. If the difference +-- in *runtime* for the compiler is too small to measure it's likely +-- better to use a regular Maybe instead. +-- +-- This is since it causes more function arguments to be passed, and +-- potentially more variables to be captured by closures increasing +-- closure size. +newtype MaybeUB a = MaybeUB (# (# #) | a #) + +pattern JustUB :: a -> MaybeUB a +pattern JustUB x = MaybeUB (# | x #) + +pattern NothingUB :: MaybeUB a +pattern NothingUB = MaybeUB (# (# #) | #) + +{-# COMPLETE NothingUB, JustUB #-} + +fromMaybeUB :: a -> MaybeUB a -> a +fromMaybeUB d NothingUB = d +fromMaybeUB _ (JustUB x) = x + +apMaybeUB :: MaybeUB (a -> b) -> MaybeUB a -> MaybeUB b +apMaybeUB (JustUB f) (JustUB x) = JustUB (f x) +apMaybeUB _ _ = NothingUB + +fmapMaybeUB :: (a -> b) -> MaybeUB a -> MaybeUB b +fmapMaybeUB _f NothingUB = NothingUB +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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 0ac1080c65..8e71fcaf31 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -387,6 +387,7 @@ Library GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap + GHC.Data.Unboxed GHC.Data.UnionFind GHC.Driver.Backend GHC.Driver.Backend.Internal diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 423fd15533..3a6bae10fb 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -96,6 +96,7 @@ GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap +GHC.Data.Unboxed GHC.Driver.Backend GHC.Driver.Backend.Internal GHC.Driver.CmdLine diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index b6e55ec846..df3f46f307 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -96,6 +96,7 @@ GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap +GHC.Data.Unboxed GHC.Driver.Backend GHC.Driver.Backend.Internal GHC.Driver.Backpack.Syntax -- cgit v1.2.1