[Git][ghc/ghc][wip/ioref-swap-xchg] 7 commits: Optimized Foldable methods for Data.Functor.Compose
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Mar 24 04:11:44 UTC 2023
Ben Gamari pushed to branch wip/ioref-swap-xchg at Glasgow Haskell Compiler / GHC
Commits:
8c98deba by Armando Ramirez at 2023-03-23T09:19:32-04:00
Optimized Foldable methods for Data.Functor.Compose
Explicitly define length, elem, etc. in Foldable instance for Data.Functor.Compose
Implementation of https://github.com/haskell/core-libraries-committee/issues/57
- - - - -
bc066108 by Armando Ramirez at 2023-03-23T09:19:32-04:00
Additional optimized versions
- - - - -
80fce576 by Bodigrim at 2023-03-23T09:19:32-04:00
Simplify minimum/maximum in instance Foldable (Compose f g)
- - - - -
8cb88a5a by Bodigrim at 2023-03-23T09:19:32-04:00
Update changelog to mention changes to instance Foldable (Compose f g)
- - - - -
e1c8c41d by Torsten Schmits at 2023-03-23T09:20:13-04:00
Add structured error messages for GHC.Tc.TyCl.PatSyn
Tracking ticket: #20117
MR: !10158
This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.
- - - - -
4f32b5e5 by Ben Gamari at 2023-03-24T00:00:27-04:00
testsuite: Add test for atomicSwapIORef
- - - - -
cf7678b8 by Ben Gamari at 2023-03-24T00:10:17-04:00
compiler: Implement atomicSwapIORef with xchg
- - - - -
27 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Types/Error/Codes.hs
- libraries/base/Data/Functor/Compose.hs
- libraries/base/GHC/IORef.hs
- libraries/base/changelog.md
- + libraries/base/tests/AtomicSwapIORef.hs
- + libraries/base/tests/AtomicSwapIORef.stdout
- libraries/base/tests/all.T
- rts/PrimOps.cmm
- rts/RtsSymbols.c
- rts/include/Cmm.h
- rts/include/stg/MiscClosures.h
- testsuite/tests/patsyn/should_fail/T14112.stderr
- testsuite/tests/patsyn/should_fail/T14507.stderr
- testsuite/tests/patsyn/should_fail/unidir.stderr
- + testsuite/tests/typecheck/should_fail/PatSynArity.hs
- + testsuite/tests/typecheck/should_fail/PatSynArity.stderr
- + testsuite/tests/typecheck/should_fail/PatSynExistential.hs
- + testsuite/tests/typecheck/should_fail/PatSynExistential.stderr
- + testsuite/tests/typecheck/should_fail/PatSynUnboundVar.hs
- + testsuite/tests/typecheck/should_fail/PatSynUnboundVar.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2513,6 +2513,13 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp
has_side_effects = True
code_size = { primOpCodeSizeForeignCall } -- for the write barrier
+primop AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp
+ MutVar# s v -> v -> State# s -> (# State# s, v #)
+ {Atomically exchange the value of a 'MutVar#'.}
+ with
+ out_of_line = True
+ has_side_effects = True
+
-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Looking at the type of atomicModifyMutVar2#, one might wonder why
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1559,6 +1559,7 @@ emitPrimOp cfg primop =
ResizeMutableByteArrayOp_Char -> alwaysExternal
ShrinkSmallMutableArrayOp_Char -> alwaysExternal
NewMutVarOp -> alwaysExternal
+ AtomicSwapMutVarOp -> alwaysExternal
AtomicModifyMutVar2Op -> alwaysExternal
AtomicModifyMutVar_Op -> alwaysExternal
CasMutVarOp -> alwaysExternal
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -859,6 +859,8 @@ genPrim prof bound ty op = case op of
AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f]
AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f]
+ AtomicSwapMutVarOp -> \[r] [mv,v] -> PrimInline $ mconcat
+ [ r |= mv .^ "val", mv .^ "val" |= v ]
CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o)
(mconcat [status |= zero_, r |= n, mv .^ "val" |= n])
(mconcat [status |= one_ , r |= mv .^ "val"])
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1481,6 +1481,32 @@ instance Diagnostic TcRnMessage where
, text "(Indeed, I sometimes struggle even printing this correctly,"
, text " due to its ill-scoped nature.)"
]
+ TcRnPatSynEscapedCoercion arg bad_co_ne -> mkSimpleDecorated $
+ vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!"
+ , hang (text "Pattern-bound variable")
+ 2 (ppr arg <+> dcolon <+> ppr (idType arg))
+ , nest 2 $
+ hang (text "has a type that mentions pattern-bound coercion"
+ <> plural bad_co_list <> colon)
+ 2 (pprWithCommas ppr bad_co_list)
+ , text "Hint: use -fprint-explicit-coercions to see the coercions"
+ , text "Probable fix: add a pattern signature" ]
+ where
+ bad_co_list = NE.toList bad_co_ne
+ TcRnPatSynExistentialInResult name pat_ty bad_tvs -> mkSimpleDecorated $
+ hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
+ , text "namely" <+> quotes (ppr pat_ty) ])
+ 2 (text "mentions existential type variable" <> plural bad_tvs
+ <+> pprQuotedList bad_tvs)
+ TcRnPatSynArityMismatch name decl_arity missing -> mkSimpleDecorated $
+ hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"
+ <+> speakNOf decl_arity (text "argument"))
+ 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
+ TcRnPatSynInvalidRhs ps_name lpat args reason -> mkSimpleDecorated $
+ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
+ <+> quotes (ppr ps_name) <> colon)
+ 2 (pprPatSynInvalidRhsReason ps_name lpat args reason)
+ , text "RHS pattern:" <+> ppr lpat ]
diagnosticReason = \case
TcRnUnknownMessage m
@@ -1965,6 +1991,14 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnSkolemEscape{}
-> ErrorWithoutFlag
+ TcRnPatSynEscapedCoercion{}
+ -> ErrorWithoutFlag
+ TcRnPatSynExistentialInResult{}
+ -> ErrorWithoutFlag
+ TcRnPatSynArityMismatch{}
+ -> ErrorWithoutFlag
+ TcRnPatSynInvalidRhs{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2467,6 +2501,14 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnSkolemEscape{}
-> noHints
+ TcRnPatSynEscapedCoercion{}
+ -> noHints
+ TcRnPatSynExistentialInResult{}
+ -> noHints
+ TcRnPatSynArityMismatch{}
+ -> noHints
+ TcRnPatSynInvalidRhs{}
+ -> noHints
diagnosticCode = constructorCode
@@ -4561,3 +4603,18 @@ pprUninferrableTyvarCtx = \case
UninfTyCtx_Sig exp_kind full_hs_ty ->
hang (text "the kind" <+> ppr exp_kind) 2
(text "of the type signature:" <+> ppr full_hs_ty)
+
+pprPatSynInvalidRhsReason :: Name -> LPat GhcRn -> [LIdP GhcRn] -> PatSynInvalidRhsReason -> SDoc
+pprPatSynInvalidRhsReason name pat args = \case
+ PatSynNotInvertible p ->
+ text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
+ $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
+ <+> text "pattern synonym, e.g.")
+ 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
+ <+> ppr pat <+> text "where")
+ 2 (pp_name <+> pp_args <+> equals <+> text "..."))
+ where
+ pp_name = ppr name
+ pp_args = hsep (map ppr args)
+ PatSynUnboundVar var ->
+ quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym"
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -95,6 +95,7 @@ module GHC.Tc.Errors.Types (
, WrongThingSort(..)
, StageCheckReason(..)
, UninferrableTyvarCtx(..)
+ , PatSynInvalidRhsReason(..)
) where
import GHC.Prelude
@@ -108,7 +109,7 @@ import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)
, UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing
, FixedRuntimeRepOrigin(..), InstanceWhat )
import GHC.Tc.Types.Rank (Rank)
-import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)
+import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType, TcSigmaType)
import GHC.Types.Avail (AvailInfo)
import GHC.Types.Error
import GHC.Types.Hint (UntickedPromotedThing(..))
@@ -118,7 +119,7 @@ import qualified GHC.Types.Name.Occurrence as OccName
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.TyThing (TyThing)
-import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar)
+import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar, CoVar)
import GHC.Types.Var.Env (TidyEnv)
import GHC.Types.Var.Set (TyVarSet, VarSet)
import GHC.Unit.Types (Module)
@@ -3293,6 +3294,52 @@ data TcRnMessage where
-> !Type -- ^ The type in which they occur.
-> TcRnMessage
+ {-| TcRnPatSynEscapedCoercion is an error indicating that a coercion escaped from
+ a pattern synonym into a type.
+ See Note [Coercions that escape] in GHC.Tc.TyCl.PatSyn
+
+ Test cases:
+ T14507
+ -}
+ TcRnPatSynEscapedCoercion :: !Id -- ^ The pattern-bound variable
+ -> !(NE.NonEmpty CoVar) -- ^ The escaped coercions
+ -> TcRnMessage
+
+ {-| TcRnPatSynExistentialInResult is an error indicating that the result type
+ of a pattern synonym mentions an existential type variable.
+
+ Test cases:
+ PatSynExistential
+ -}
+ TcRnPatSynExistentialInResult :: !Name -- ^ The name of the pattern synonym
+ -> !TcSigmaType -- ^ The result type
+ -> ![TyVar] -- ^ The escaped existential variables
+ -> TcRnMessage
+
+ {-| TcRnPatSynArityMismatch is an error indicating that the number of arguments in a
+ pattern synonym's equation differs from the number of parameters in its
+ signature.
+
+ Test cases:
+ PatSynArity
+ -}
+ TcRnPatSynArityMismatch :: !Name -- ^ The name of the pattern synonym
+ -> !Arity -- ^ The number of equation arguments
+ -> !Arity -- ^ The difference
+ -> TcRnMessage
+
+ {-| TcRnPatSynInvalidRhs is an error group indicating that the pattern on the
+ right hand side of a pattern synonym is invalid.
+
+ Test cases:
+ unidir, T14112
+ -}
+ TcRnPatSynInvalidRhs :: !Name -- ^ The name of the pattern synonym
+ -> !(LPat GhcRn) -- ^ The pattern
+ -> ![LIdP GhcRn] -- ^ The LHS args
+ -> !PatSynInvalidRhsReason -- ^ The number of equation arguments
+ -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
@@ -4582,3 +4629,8 @@ data UninferrableTyvarCtx
| UninfTyCtx_TyfamRhs TcType
| UninfTyCtx_TysynRhs TcType
| UninfTyCtx_Sig TcType (LHsSigType GhcRn)
+
+data PatSynInvalidRhsReason
+ = PatSynNotInvertible !(Pat GhcRn)
+ | PatSynUnboundVar !Name
+ deriving (Generic)
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
import GHC.Core.Predicate
import GHC.Builtin.Types.Prim
-import GHC.Types.Error
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
@@ -68,6 +67,7 @@ import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )
import Data.Maybe( mapMaybe )
import Control.Monad ( zipWithM )
import Data.List( partition, mapAccumL )
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
{-
************************************************************************
@@ -185,10 +185,11 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
-- Report coercions that escape
-- See Note [Coercions that escape]
; args <- mapM zonkId args
- ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
- , let bad_cos = filterDVarSet isId $
- (tyCoVarsOfTypeDSet (idType arg))
- , not (isEmptyDVarSet bad_cos) ]
+ ; let bad_arg arg = fmap (\bad_cos -> (arg, bad_cos)) $
+ nonEmpty $
+ dVarSetElems $
+ filterDVarSet isId (tyCoVarsOfTypeDSet (idType arg))
+ bad_args = mapMaybe bad_arg (args ++ prov_dicts)
; mapM_ dependentArgErr bad_args
-- Report un-quantifiable type variables:
@@ -236,22 +237,11 @@ mkProvEvidence ev_id
pred = evVarPred ev_id
eq_con_args = [evId ev_id]
-dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
+dependentArgErr :: (Id, NonEmpty CoVar) -> TcM ()
-- See Note [Coercions that escape]
dependentArgErr (arg, bad_cos)
= failWithTc $ -- fail here: otherwise we get downstream errors
- mkTcRnUnknownMessage $ mkPlainError noHints $
- vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!"
- , hang (text "Pattern-bound variable")
- 2 (ppr arg <+> dcolon <+> ppr (idType arg))
- , nest 2 $
- hang (text "has a type that mentions pattern-bound coercion"
- <> plural bad_co_list <> colon)
- 2 (pprWithCommas ppr bad_co_list)
- , text "Hint: use -fprint-explicit-coercions to see the coercions"
- , text "Probable fix: add a pattern signature" ]
- where
- bad_co_list = dVarSetElems bad_cos
+ TcRnPatSynEscapedCoercion arg bad_cos
{- Note [Type variables whose kind is captured]
~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -405,11 +395,7 @@ tcCheckPatSynDecl psb at PSB{ psb_id = lname@(L _ name), psb_args = details
-- The existential 'x' should not appear in the result type
-- Can't check this until we know P's arity (decl_arity above)
; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs
- ; checkTc (null bad_tvs) $ mkTcRnUnknownMessage $ mkPlainError noHints $
- hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
- , text "namely" <+> quotes (ppr pat_ty) ])
- 2 (text "mentions existential type variable" <> plural bad_tvs
- <+> pprQuotedList bad_tvs)
+ ; checkTc (null bad_tvs) $ TcRnPatSynExistentialInResult name pat_ty bad_tvs
-- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig
; let univ_fvs = closeOverKinds $
@@ -679,10 +665,7 @@ collectPatSynArgInfo details =
wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
wrongNumberOfParmsErr name decl_arity missing
- = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
- hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"
- <+> speakNOf decl_arity (text "argument"))
- 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
+ = failWithTc $ TcRnPatSynArityMismatch name decl_arity missing
-------------------------
-- Shared by both tcInferPatSyn and tcCheckPatSyn
@@ -921,11 +904,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
= return emptyBag
| Left why <- mb_match_group -- Can't invert the pattern
- = setSrcSpan (getLocA lpat) $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
- vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
- <+> quotes (ppr ps_name) <> colon)
- 2 why
- , text "RHS pattern:" <+> ppr lpat ]
+ = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why
| Right match_group <- mb_match_group -- Bidirectional
= do { patsyn <- tcLookupPatSyn ps_name
@@ -975,7 +954,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
mb_match_group
= case dir of
ExplicitBidirectional explicit_mg -> Right explicit_mg
- ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat)
+ ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
@@ -1019,8 +998,8 @@ add_void need_dummy_arg ty
| need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty
| otherwise = ty
-tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
- -> Either SDoc (LHsExpr GhcRn)
+tcPatToExpr :: [LocatedN Name] -> LPat GhcRn
+ -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
-- Given a /pattern/, return an /expression/ that builds a value
-- that matches the pattern. E.g. if the pattern is (Just [x]),
-- the expression is (Just [x]). They look the same, but the
@@ -1029,13 +1008,13 @@ tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
--
-- Returns (Left r) if the pattern is not invertible, for reason r.
-- See Note [Builder for a bidirectional pattern synonym]
-tcPatToExpr name args pat = go pat
+tcPatToExpr args pat = go pat
where
lhsVars = mkNameSet (map unLoc args)
-- Make a prefix con for prefix and infix patterns for simplicity
mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]
- -> Either SDoc (HsExpr GhcRn)
+ -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkPrefixConExpr lcon@(L loc _) pats
= do { exprs <- mapM go pats
; let con = L (l2l loc) (HsVar noExtField lcon)
@@ -1043,18 +1022,18 @@ tcPatToExpr name args pat = go pat
}
mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)
- -> Either SDoc (HsExpr GhcRn)
+ -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
mkRecordConExpr con (HsRecFields fields dd)
= do { exprFields <- mapM go' fields
; return (RecordCon noExtField con (HsRecFields exprFields dd)) }
- go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn))
+ go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn))
go' (L l rf) = L l <$> traverse go rf
- go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
+ go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn)
go (L loc p) = L loc <$> go1 p
- go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
+ go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn)
go1 (ConPat NoExtField con info)
= case info of
PrefixCon _ ps -> mkPrefixConExpr con ps
@@ -1068,7 +1047,7 @@ tcPatToExpr name args pat = go pat
| var `elemNameSet` lhsVars
= return $ HsVar noExtField (L l var)
| otherwise
- = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
+ = Left (PatSynUnboundVar var)
go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat
go1 (ListPat _ pats)
= do { exprs <- mapM go pats
@@ -1105,19 +1084,7 @@ tcPatToExpr name args pat = go pat
go1 p@(AsPat {}) = notInvertible p
go1 p@(NPlusKPat {}) = notInvertible p
- notInvertible p = Left (not_invertible_msg p)
-
- not_invertible_msg p
- = text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
- $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
- <+> text "pattern synonym, e.g.")
- 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
- <+> ppr pat <+> text "where")
- 2 (pp_name <+> pp_args <+> equals <+> text "..."))
- where
- pp_name = ppr name
- pp_args = hsep (map ppr args)
-
+ notInvertible p = Left (PatSynNotInvertible p)
{- Note [Builder for a bidirectional pattern synonym]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -542,6 +542,11 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnCannotDefaultKindVar" = 79924
GhcDiagnosticCode "TcRnUninferrableTyvar" = 16220
GhcDiagnosticCode "TcRnSkolemEscape" = 71451
+ GhcDiagnosticCode "TcRnPatSynEscapedCoercion" = 88986
+ GhcDiagnosticCode "TcRnPatSynExistentialInResult" = 33973
+ GhcDiagnosticCode "TcRnPatSynArityMismatch" = 18365
+ GhcDiagnosticCode "PatSynNotInvertible" = 69317
+ GhcDiagnosticCode "PatSynUnboundVar" = 28572
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
@@ -711,6 +716,7 @@ type family ConRecursInto con where
ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError
ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason
ConRecursInto "TcRnHsigShapeMismatch" = 'Just HsigShapeMismatchReason
+ ConRecursInto "TcRnPatSynInvalidRhs" = 'Just PatSynInvalidRhsReason
--
-- TH errors
=====================================
libraries/base/Data/Functor/Compose.hs
=====================================
@@ -31,6 +31,8 @@ import Data.Functor.Classes
import Control.Applicative
import Data.Coerce (coerce)
import Data.Data (Data)
+import Data.Foldable (Foldable(..))
+import Data.Monoid (Sum(..), All(..), Any(..), Product(..))
import Data.Type.Equality (TestEquality(..), (:~:)(..))
import GHC.Generics (Generic, Generic1)
import Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault)
@@ -111,7 +113,23 @@ instance (Functor f, Functor g) => Functor (Compose f g) where
-- | @since 4.9.0.0
instance (Foldable f, Foldable g) => Foldable (Compose f g) where
+ fold (Compose t) = foldMap fold t
foldMap f (Compose t) = foldMap (foldMap f) t
+ foldMap' f (Compose t) = foldMap' (foldMap' f) t
+ foldr f b (Compose fga) = foldr (\ga acc -> foldr f acc ga) b fga
+ foldr' f b (Compose fga) = foldr' (\ga acc -> foldr' f acc ga) b fga
+ foldl f b (Compose fga) = foldl (\acc ga -> foldl f acc ga) b fga
+ foldl' f b (Compose fga) = foldl' (\acc ga -> foldl' f acc ga) b fga
+
+ null (Compose t) = null t || getAll (foldMap (All . null) t)
+ length (Compose t) = getSum (foldMap' (Sum . length) t)
+ elem x (Compose t) = getAny (foldMap (Any . elem x) t)
+
+ minimum (Compose fga) = minimum $ map minimum $ filter (not . null) $ toList fga
+ maximum (Compose fga) = maximum $ map maximum $ filter (not . null) $ toList fga
+
+ sum (Compose t) = getSum (foldMap' (Sum . sum) t)
+ product (Compose t) = getProduct (foldMap' (Product . product) t)
-- | @since 4.9.0.0
instance (Traversable f, Traversable g) => Traversable (Compose f g) where
=====================================
libraries/base/GHC/IORef.hs
=====================================
@@ -127,12 +127,9 @@ atomicModifyIORef'_ ref f = do
-- | Atomically replace the contents of an 'IORef', returning
-- the old contents.
atomicSwapIORef :: IORef a -> a -> IO a
--- Bad implementation! This will be a primop shortly.
atomicSwapIORef (IORef (STRef ref)) new = IO $ \s ->
- case atomicModifyMutVar2# ref (\_old -> Box new) s of
- (# s', old, Box _new #) -> (# s', old #)
-
-data Box a = Box a
+ case atomicSwapMutVar# ref new s of
+ (# s', old #) -> (# s', old #)
-- | Strict version of 'Data.IORef.atomicModifyIORef'. This forces both
-- the value stored in the 'IORef' and the value returned. The new value
=====================================
libraries/base/changelog.md
=====================================
@@ -12,6 +12,8 @@
* Add `Type.Reflection.decTypeRep`, `Data.Typeable.decT` and `Data.Typeable.hdecT` equality decisions functions.
([CLC proposal #98](https://github.com/haskell/core-libraries-committee/issues/98))
* Add `Data.Functor.unzip` ([CLC proposal #88](https://github.com/haskell/core-libraries-committee/issues/88))
+ * Implement more members of `instance Foldable (Compose f g)` explicitly.
+ ([CLC proposal #57](https://github.com/haskell/core-libraries-committee/issues/57))
## 4.18.0.0 *TBA*
=====================================
libraries/base/tests/AtomicSwapIORef.hs
=====================================
@@ -0,0 +1,8 @@
+import Data.IORef
+import GHC.IORef
+
+main :: IO ()
+main = do
+ r <- newIORef 42 :: IO (IORef Int)
+ mapM (atomicSwapIORef r) [0..1000] >>= print
+ readIORef r >>= print
=====================================
libraries/base/tests/AtomicSwapIORef.stdout
=====================================
@@ -0,0 +1,2 @@
+[42,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999]
+1000
=====================================
libraries/base/tests/all.T
=====================================
@@ -296,3 +296,4 @@ test('T22816', normal, compile_and_run, [''])
test('trace', normal, compile_and_run, [''])
test('listThreads', js_broken(22261), compile_and_run, [''])
test('inits1tails1', normal, compile_and_run, [''])
+test('AtomicSwapIORef', normal, compile_and_run, [''])
=====================================
rts/PrimOps.cmm
=====================================
@@ -689,6 +689,17 @@ stg_newMutVarzh ( gcptr init )
return (mv);
}
+stg_atomicSwapMutVarzh ( gcptr mv, gcptr new )
+ /* MutVar# s a -> a -> State# s -> (# State#, a #) */
+{
+ W_ old;
+ (old) = prim %xchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old);
+ if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
+ ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr", old "ptr");
+ }
+ return (old);
+}
+
// RRN: To support the "ticketed" approach, we return the NEW rather
// than old value if the CAS is successful. This is received in an
// opaque form in the Haskell code, preventing the compiler from
=====================================
rts/RtsSymbols.c
=====================================
@@ -633,6 +633,7 @@ extern char **environ;
SymI_HasDataProto(stg_writeIOPortzh) \
SymI_HasDataProto(stg_newIOPortzh) \
SymI_HasDataProto(stg_noDuplicatezh) \
+ SymI_HasDataProto(stg_atomicSwapMutVarzh) \
SymI_HasDataProto(stg_atomicModifyMutVar2zh) \
SymI_HasDataProto(stg_atomicModifyMutVarzuzh) \
SymI_HasDataProto(stg_casMutVarzh) \
=====================================
rts/include/Cmm.h
=====================================
@@ -193,8 +193,10 @@
#if SIZEOF_W == 4
#define cmpxchgW cmpxchg32
+#define xchgW xchg32
#elif SIZEOF_W == 8
#define cmpxchgW cmpxchg64
+#define xchgW xchg64
#endif
/* -----------------------------------------------------------------------------
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -481,6 +481,7 @@ RTS_FUN_DECL(stg_copySmallMutableArrayzh);
RTS_FUN_DECL(stg_casSmallArrayzh);
RTS_FUN_DECL(stg_newMutVarzh);
+RTS_FUN_DECL(stg_atomicSwapMutVarzh);
RTS_FUN_DECL(stg_atomicModifyMutVar2zh);
RTS_FUN_DECL(stg_atomicModifyMutVarzuzh);
RTS_FUN_DECL(stg_casMutVarzh);
=====================================
testsuite/tests/patsyn/should_fail/T14112.stderr
=====================================
@@ -1,5 +1,5 @@
-T14112.hs:5:21: error:
+T14112.hs:5:21: error: [GHC-69317]
Invalid right-hand side of bidirectional pattern synonym ‘MyJust1’:
Pattern ‘!a’ is not invertible
Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
=====================================
testsuite/tests/patsyn/should_fail/T14507.stderr
=====================================
@@ -1,5 +1,5 @@
-T14507.hs:21:1: error:
+T14507.hs:21:1: error: [GHC-88986]
• Iceland Jack! Iceland Jack! Stop torturing me!
Pattern-bound variable x :: TypeRep a
has a type that mentions pattern-bound coercion: co
=====================================
testsuite/tests/patsyn/should_fail/unidir.stderr
=====================================
@@ -1,5 +1,5 @@
-unidir.hs:4:18: error:
+unidir.hs:4:18: error: [GHC-69317]
Invalid right-hand side of bidirectional pattern synonym ‘Head’:
Pattern ‘_’ is not invertible
Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
=====================================
testsuite/tests/typecheck/should_fail/PatSynArity.hs
=====================================
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynArity where
+
+pattern P :: Int -> (Int, Int)
+pattern P a b = (a, b)
=====================================
testsuite/tests/typecheck/should_fail/PatSynArity.stderr
=====================================
@@ -0,0 +1,4 @@
+PatSynArity.hs:6:1: [GHC-18365]
+ Pattern synonym ‘P’ has two arguments
+ but its type signature has 1 fewer arrows
+ In the declaration for pattern synonym ‘P’
=====================================
testsuite/tests/typecheck/should_fail/PatSynExistential.hs
=====================================
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynExistential where
+
+pattern P :: () => forall x. x -> Maybe x
+pattern P <- _
=====================================
testsuite/tests/typecheck/should_fail/PatSynExistential.stderr
=====================================
@@ -0,0 +1,4 @@
+PatSynExistential.hs:6:1: [GHC-33973]
+ The result type of the signature for ‘P’, namely ‘x -> Maybe x’
+ mentions existential type variable ‘x’
+ In the declaration for pattern synonym ‘P’
=====================================
testsuite/tests/typecheck/should_fail/PatSynUnboundVar.hs
=====================================
@@ -0,0 +1,6 @@
+{-# language PatternSynonyms #-}
+
+module PatSynUnboundVar where
+
+pattern P :: Int -> (Int, Int)
+pattern P a = (a, b)
=====================================
testsuite/tests/typecheck/should_fail/PatSynUnboundVar.stderr
=====================================
@@ -0,0 +1,4 @@
+PatSynUnboundVar.hs:6:15: [GHC-28572]
+ Invalid right-hand side of bidirectional pattern synonym ‘P’:
+ ‘b’ is not bound by the LHS of the pattern synonym
+ RHS pattern: (a, b)
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -672,3 +672,6 @@ test('T22924a', normal, compile_fail, [''])
test('T22924b', normal, compile_fail, [''])
test('T22940', normal, compile_fail, [''])
test('T19627', normal, compile_fail, [''])
+test('PatSynExistential', normal, compile_fail, [''])
+test('PatSynArity', normal, compile_fail, [''])
+test('PatSynUnboundVar', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/129e7ff13e577c68a5084cbdb9978e1ebebbee0c...cf7678b8bd8207fd405e9bed51fb16d64d2a24ec
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/129e7ff13e577c68a5084cbdb9978e1ebebbee0c...cf7678b8bd8207fd405e9bed51fb16d64d2a24ec
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/20230324/c8e6085d/attachment-0001.html>
More information about the ghc-commits
mailing list