[Git][ghc/ghc][wip/andreask/opt-core-lint] Apply some tricks to speed up core lint.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Mon Sep 26 23:22:59 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/opt-core-lint at Glasgow Haskell Compiler / GHC
Commits:
829609bd by Andreas Klebinger at 2022-09-27T01:12:15+02:00
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
-------------------------
- - - - -
9 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- + compiler/GHC/Data/Unboxed.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
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
=====================================
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
=====================================
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
=====================================
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
----------------
=====================================
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 #-}
=====================================
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
=====================================
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
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/829609bde5eb0725c5bb80fbf6543811d5531123
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/829609bde5eb0725c5bb80fbf6543811d5531123
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220926/9cf5bac9/attachment-0001.html>
More information about the ghc-commits
mailing list