[Git][ghc/ghc][wip/andreask/opt-core-lint] Apply some tricks to speed up core lint.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Wed Sep 21 09:31:23 UTC 2022
Andreas Klebinger pushed to branch wip/andreask/opt-core-lint at Glasgow Haskell Compiler / GHC
Commits:
23a93bb5 by Andreas Klebinger at 2022-09-21T11:30:13+02:00
Apply some tricks to speed up core lint.
Below are the noteworthy changes and if given their impact on compiler
allocations.
* 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: Return a unboxed maybe: ~1%
- - - - -
7 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
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternSynonyms #-}
{-
(c) The University of Glasgow 2006
@@ -163,6 +164,7 @@ import Control.Monad (foldM, zipWithM)
import Data.Function ( on )
import Data.Char( isDigit )
import qualified Data.Monoid as Monoid
+import GHC.Data.Unboxed (pattern JustUB)
{-
%************************************************************************
@@ -781,7 +783,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
+ | JustUB (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
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-- (c) The University of Glasgow 2006
@@ -62,6 +63,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.Bag
+import GHC.Data.Unboxed
{-
************************************************************************
@@ -1370,7 +1372,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
+ | JustUB (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,10 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# OPTIONS_GHC -ddump-stg-final -ddump-simpl -ddump-to-file #-}
{-
(c) The University of Glasgow 2006
@@ -95,6 +99,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 +269,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 +1867,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
+ | JustUB (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 +1916,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,45 +1935,56 @@ 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
+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 () }
+ ; go_app in_scope kfn arg_tys
+ -- ; _ <- foldlM (go_app in_scope) kfn arg_tys
+ -- ; return ()
+ }
where
- fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc
+ -- We pass kfn arg_tys explicitly here to avoid this binder becoming a thunk
+ -- that get's allocated in the hot code path.
+ -- See Note [Avoiding compiler perf traps when constructing error messages.]
+ fail_msg kfn arg_tys 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 ]
- go_app in_scope kfn ta
+ 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 (fail_msg kfn arg_tys msg_type (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka)))
+ ; go_app in_scope kfb tas }
+ -- ; return kfb }
- 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 (fail_msg kfn arg_tys 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 (fail_msg kfn arg_tys msg_type (text "Not a fun:" <+> (ppr kfn $$ ppr ta)))
{- *********************************************************************
* *
@@ -2672,14 +2727,42 @@ 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)
+-- type WarnsAndErrs = (# Bag SDoc, Bag SDoc #)
+
+type LResult a = (# MaybeUB a, WarnsAndErrs #)
+
+pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a
+pattern LResult m w <- (# m, w #)
+ where 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 +2887,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 +2940,10 @@ 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
+ -- (Just _, 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 +2972,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 +2988,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 +3028,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 +3044,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 +3064,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
=====================================
@@ -2,6 +2,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_GHC -ddump-stg-final -ddump-simpl -ddump-to-file #-}
+{-# LANGUAGE UnboxedTuples #-}
{-
(c) The University of Glasgow 2006
@@ -177,6 +179,7 @@ import GHC.Unit.Module
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import qualified Data.Data as Data
+import GHC.Data.Unboxed
{-
-----------------------------------------------
@@ -2524,7 +2527,7 @@ isConcreteTyConFlavour = \case
expandSynTyCon_maybe
:: TyCon
-> [tyco] -- ^ Arguments to 'TyCon'
- -> Maybe ([(TyVar,tyco)],
+ -> MaybeUB ([(TyVar,tyco)],
Type,
[tyco]) -- ^ Returns a 'TyVar' substitution, the body
-- type of the synonym (not yet substituted)
@@ -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 JustUB ([], 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 -> JustUB (tvs `zip` tys, rhs, drop arity tys)
+ EQ -> JustUB (tvs `zip` tys, rhs, [])
+ LT -> NothingUB
| otherwise
- = Nothing
+ = NothingUB
----------------
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -4,8 +4,10 @@
-- Type - public interface
{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE MagicHash #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -ddump-stg-final -ddump-simpl -ddump-to-file #-}
-- | Main functions for manipulating types and type-related things
module GHC.Core.Type (
@@ -296,6 +298,8 @@ import GHC.Types.Unique ( nonDetCmpUnique )
import GHC.Data.Maybe ( orElse, expectJust, isJust )
import Control.Monad ( guard )
+import GHC.Base (reallyUnsafePtrEquality#)
+import GHC.Data.Unboxed
-- import GHC.Utils.Trace
-- $type_classification
@@ -555,7 +559,7 @@ expandTypeSynonyms ty
in_scope = mkInScopeSet (tyCoVarsOfType ty)
go subst (TyConApp tc tys)
- | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys
+ | JustUB (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
@@ -2799,11 +2803,14 @@ See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.
-}
nonDetCmpType :: Type -> Type -> Ordering
+nonDetCmpType !t1 !t2
+ | 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,92 @@
+-- Strict counterparts to common data structures,
+-- e.g. tuples, lists, maybes, etc.
+--
+-- Import this module qualified as Strict.
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE MagicHash #-}
+
+module GHC.Data.Unboxed (
+ -- Maybe(Nothing, Just),
+ -- fromMaybe,
+ -- Pair(And),
+
+ -- -- Not used at the moment:
+ -- --
+ -- -- Either(Left, Right),
+ -- -- List(Nil, Cons),
+ pattern JustUB, pattern NothingUB,
+
+ MaybeUB, fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB
+ ) where
+
+import GHC.Prelude hiding (Maybe(..), Either(..))
+
+-- | Like Maybe, but using unboxed sums.
+type MaybeUB a = (# (# #) | a #)
+
+pattern JustUB :: a -> MaybeUB a
+pattern JustUB x <- (# | x #) where
+ JustUB x = (# | x #)
+
+pattern NothingUB :: MaybeUB a
+pattern NothingUB <- (# (# #) | #) where
+ NothingUB = (# (##) | #)
+
+{-# COMPLETE NothingUB, JustUB #-}
+
+-- data Maybe a = Nothing | Just !a
+-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
+
+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
+
+-- altMaybe :: Maybe a -> Maybe a -> Maybe a
+-- altMaybe Nothing r = r
+-- altMaybe l _ = l
+
+-- instance Semigroup a => Semigroup (Maybe a) where
+-- Nothing <> b = b
+-- a <> Nothing = a
+-- Just a <> Just b = Just (a <> b)
+
+-- instance Semigroup a => Monoid (Maybe a) where
+-- mempty = Nothing
+
+-- instance Applicative Maybe where
+-- pure = Just
+-- (<*>) = apMaybe
+
+-- instance Alternative Maybe where
+-- empty = Nothing
+-- (<|>) = altMaybe
+
+-- data Pair a b = !a `And` !b
+-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
+
+-- The definitions below are commented out because they are
+-- not used anywhere in the compiler, but are useful to showcase
+-- the intent behind this module (i.e. how it may evolve).
+--
+-- data Either a b = Left !a | Right !b
+-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
+--
+-- data List a = Nil | !a `Cons` !(List a)
+-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/23a93bb5957a615f0c7504474710f48d59acde00
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/23a93bb5957a615f0c7504474710f48d59acde00
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/20220921/ec9b8f43/attachment-0001.html>
More information about the ghc-commits
mailing list