[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Fix bad bug in mkSynonymTyCon, re forgetfulness
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jul 24 07:12:53 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
55117e13 by Simon Peyton Jones at 2024-07-24T02:41:12-04:00
Fix bad bug in mkSynonymTyCon, re forgetfulness
As #25094 showed, the previous tests for forgetfulness was
plain wrong, when there was a forgetful synonym in the RHS
of a synonym.
- - - - -
2fd0c439 by Sergey Vinokurov at 2024-07-24T03:12:31-04:00
Define Eq1, Ord1, Show1 and Read1 instances for basic Generic representation types
This way the Generically1 newtype could be used to derive Eq1 and Ord1
for user types with DerivingVia.
The CLC proposal is https://github.com/haskell/core-libraries-committee/issues/273.
The GHC issue is https://gitlab.haskell.org/ghc/ghc/-/issues/24312.
- - - - -
6a13e672 by Simon Peyton Jones at 2024-07-24T03:12:31-04:00
Address #25055, by disabling case-of-runRW# in Gentle phase
See Note [Case-of-case and full laziness]
in GHC.Driver.Config.Core.Opt.Simplify
- - - - -
16 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- libraries/base/changelog.md
- libraries/base/src/Data/Functor/Classes.hs
- libraries/ghc-internal/src/GHC/Internal/Generics.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/perf/should_run/T25055.hs
- + testsuite/tests/perf/should_run/T25055.stdout
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/typecheck/should_compile/T25094.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -860,7 +860,7 @@ data ArityOpts = ArityOpts
-- | The Arity returned is the number of value args the
-- expression can be applied to without doing much work
-exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType
+exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType
-- exprEtaExpandArity is used when eta expanding
-- e ==> \xy -> e x y
-- Nothing if the expression has arity 0
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2342,34 +2342,44 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_cont = cont, sc_hole_ty = fun_ty })
| fun_id `hasKey` runRWKey
- , [ TyArg {}, TyArg {} ] <- rev_args
- -- Do this even if (contIsStop cont)
+ , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args
+ -- Do this even if (contIsStop cont), or if seCaseCase is off.
-- See Note [No eta-expansion in runRW#]
= do { let arg_env = arg_se `setInScopeFromE` env
- ty' = contResultType cont
+
+ overall_res_ty = contResultType cont
+ -- hole_ty is the type of the current runRW# application
+ (outer_cont, new_runrw_res_ty, inner_cont)
+ | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont)
+ | otherwise = (cont, hole_ty, mkBoringStop hole_ty)
+ -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
+ -- Note [Case-of-case and full laziness]
-- If the argument is a literal lambda already, take a short cut
- -- This isn't just efficiency; if we don't do this we get a beta-redex
- -- every time, so the simplifier keeps doing more iterations.
+ -- This isn't just efficiency:
+ -- * If we don't do this we get a beta-redex every time, so the
+ -- simplifier keeps doing more iterations.
+ -- * Even more important: see Note [No eta-expansion in runRW#]
; arg' <- case arg of
Lam s body -> do { (env', s') <- simplBinder arg_env s
- ; body' <- simplExprC env' body cont
+ ; body' <- simplExprC env' body inner_cont
; return (Lam s' body') }
-- Important: do not try to eta-expand this lambda
-- See Note [No eta-expansion in runRW#]
+
_ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
; let (m,_,_) = splitFunTy fun_ty
env' = arg_env `addNewInScopeIds` [s']
cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'
- , sc_env = env', sc_cont = cont
- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
+ , sc_env = env', sc_cont = inner_cont
+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }
-- cont' applies to s', then K
; body' <- simplExprC env' arg cont'
; return (Lam s' body') }
- ; let rr' = getRuntimeRep ty'
- call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']
- ; return (emptyFloats env, call') }
+ ; let rr' = getRuntimeRep new_runrw_res_ty
+ call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']
+ ; rebuild env call' outer_cont }
---------- Simplify value arguments --------------------
rebuildCall env fun_info
@@ -2382,7 +2392,8 @@ rebuildCall env fun_info
-- Strict arguments
| isStrictArgInfo fun_info
- , seCaseCase env
+ , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
+ -- Note [Case-of-case and full laziness]
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setInScopeFromE` env) arg
(StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
@@ -3195,7 +3206,9 @@ doCaseToLet scrut case_bndr
--------------------------------------------------
reallyRebuildCase env scrut case_bndr alts cont
- | not (seCaseCase env)
+ | not (seCaseCase env) -- Only when case-of-case is on.
+ -- See GHC.Driver.Config.Core.Opt.Simplify
+ -- Note [Case-of-case and full laziness]
= do { case_expr <- simplAlts env scrut case_bndr alts
(mkBoringStop (contHoleType cont))
; rebuild env case_expr cont }
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -2315,22 +2315,27 @@ buildSynTyCon name binders res_kind roles rhs
where
is_tau = isTauTy rhs
is_fam_free = isFamFreeTy rhs
+ expanded_rhs = expandTypeSynonyms rhs
+
is_concrete = uniqSetAll isConcreteTyCon rhs_tycons
- -- NB: is_concrete is allowed to be conservative, returning False
- -- more often than it could. e.g.
+ rhs_tycons = tyConsOfType expanded_rhs
+ -- NB: we look at expanded_rhs e.g.
-- type S a b = b
-- type family F a
-- type T a = S (F a) a
- -- We will mark T as not-concrete, even though (since S ignore its first
- -- argument, it could be marked concrete.
-
- is_forgetful = not (all ((`elemVarSet` rhs_tyvars) . binderVar) binders) ||
- uniqSetAny isForgetfulSynTyCon rhs_tycons
- -- NB: is_forgetful is allowed to be conservative, returning True more often
- -- than it should. See Note [Forgetful type synonyms] in GHC.Core.TyCon
-
- rhs_tycons = tyConsOfType rhs
- rhs_tyvars = tyCoVarsOfType rhs
+ -- We want to mark T as concrete, because S ignores its first argument
+
+ is_forgetful = not (all ((`elemVarSet` expanded_rhs_tyvars) . binderVar) binders)
+ expanded_rhs_tyvars = tyCoVarsOfType expanded_rhs
+ -- See Note [Forgetful type synonyms] in GHC.Core.TyCon
+ -- To find out if this TyCon is forgetful, expand the synonyms in its RHS
+ -- and check that all of the binders are free in the expanded type.
+ -- We really only need to expand the /forgetful/ synonyms on the RHS,
+ -- but we don't currently have a function to do that.
+ -- Failing to expand the RHS led to #25094, e.g.
+ -- type Bucket a b c = Key (a,b,c)
+ -- type Key x = Any
+ -- Here Bucket is definitely forgetful!
{-
************************************************************************
=====================================
compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
=====================================
@@ -80,6 +80,7 @@ initGentleSimplMode :: DynFlags -> SimplMode
initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")
{ -- Don't do case-of-case transformations.
-- This makes full laziness work better
+ -- See Note [Case-of-case and full laziness]
sm_case_case = False
}
@@ -89,3 +90,37 @@ floatEnable dflags =
(True, True) -> FloatEnabled
(True, False)-> FloatNestedOnly
(False, _) -> FloatDisabled
+
+
+{- Note [Case-of-case and full laziness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case-of-case can hide opportunities for let-floating (full laziness).
+For example
+ rec { f = \y. case (expensive x) of (a,b) -> blah }
+We might hope to float the (expensive x) out of the \y-loop.
+But if we inline `expensive` we might get
+ \y. case (case x of I# x' -> body) of (a,b) -> blah
+Now if we do case-of-case we get
+ \y. case x if I# x2 ->
+ case body of (a,b) -> blah
+
+Sadly, at this point `body` mentions `x2`, so we can't float it out of the
+\y-loop.
+
+Solution: don't do case-of-case in the "gentle" simplification phase that
+precedes the first float-out transformation. Implementation:
+
+ * `sm_case_case` field in SimplMode
+
+ * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case
+ in GHC.Core.Opt.Simplify.Iteration.rebuildCall.
+
+Wrinkles
+
+* This applies equally to the case-of-runRW# transformation:
+ case (runRW# (\s. body)) of (a,b) -> blah
+ --->
+ runRW# (\s. case body of (a,b) -> blah)
+ Again, don't do this when `sm_case_case` is off. See #25055 for
+ a motivating example.
+-}
=====================================
libraries/base/changelog.md
=====================================
@@ -14,6 +14,7 @@
* Add `inits1` and `tails1` to `Data.List`, factored from the corresponding functions in `Data.List.NonEmpty` ([CLC proposal #252](https://github.com/haskell/core-libraries-committee/issues/252))
* Add `firstA` and `secondA` to `Data.Bitraversable`. ([CLC proposal #172](https://github.com/haskell/core-libraries-committee/issues/172))
* Deprecate `GHC.TypeNats.Internal`, `GHC.TypeLits.Internal`, `GHC.ExecutionStack.Internal` ([CLC proposal #217](https://github.com/haskell/core-libraries-committee/issues/217))
+ * Define `Eq1`, `Ord1`, `Show1` and `Read1` instances for basic `Generic` representation types. ([CLC proposal #273](https://github.com/haskell/core-libraries-committee/issues/273))
## 4.20.0.0 May 2024
* Shipped with GHC 9.10.1
=====================================
libraries/base/src/Data/Functor/Classes.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE Safe #-}
@@ -78,12 +79,13 @@ import Data.List.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Ord (Down(Down))
import Data.Complex (Complex((:+)))
-import GHC.Generics (Generic1(..), Generically1(..))
+import GHC.Generics (Generic1(..), Generically1(..), V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) , (:+:)(..), (:*:)(..), (:.:)(..), URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord)
import GHC.Tuple (Solo (..))
-import GHC.Internal.Read (expectP, list, paren)
+import GHC.Internal.Read (expectP, list, paren, readField)
+import GHC.Internal.Show (appPrec)
-import GHC.Internal.Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec)
-import GHC.Internal.Text.Read (Read(..), parens, prec, step)
+import GHC.Internal.Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec, pfail)
+import GHC.Internal.Text.Read (Read(..), parens, prec, step, reset)
import GHC.Internal.Text.Read.Lex (Lexeme(..))
import GHC.Internal.Text.Show (showListWith)
import Prelude
@@ -1123,3 +1125,322 @@ and the corresponding 'Show1' instance as
> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y
-}
+
+-- | @since base-4.21.0.0
+instance Eq1 V1 where
+ liftEq _ = \_ _ -> True
+
+-- | @since base-4.21.0.0
+instance Ord1 V1 where
+ liftCompare _ = \_ _ -> EQ
+
+-- | @since base-4.21.0.0
+instance Show1 V1 where
+ liftShowsPrec _ _ _ = \_ -> showString "V1"
+
+-- | @since base-4.21.0.0
+instance Read1 V1 where
+ liftReadsPrec _ _ = readPrec_to_S pfail
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance Eq1 U1 where
+ liftEq _ = \_ _ -> True
+
+-- | @since base-4.21.0.0
+instance Ord1 U1 where
+ liftCompare _ = \_ _ -> EQ
+
+-- | @since base-4.21.0.0
+instance Show1 U1 where
+ liftShowsPrec _ _ _ = \U1 -> showString "U1"
+
+-- | @since base-4.21.0.0
+instance Read1 U1 where
+ liftReadPrec _ _ =
+ parens (expectP (Ident "U1") *> pure U1)
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance Eq1 Par1 where
+ liftEq eq = \(Par1 a) (Par1 a') -> eq a a'
+
+-- | @since base-4.21.0.0
+instance Ord1 Par1 where
+ liftCompare cmp = \(Par1 a) (Par1 a') -> cmp a a'
+
+-- | @since base-4.21.0.0
+instance Show1 Par1 where
+ liftShowsPrec sp _ d = \(Par1 { unPar1 = a }) ->
+ showsSingleFieldRecordWith sp "Par1" "unPar1" d a
+
+-- | @since base-4.21.0.0
+instance Read1 Par1 where
+ liftReadPrec rp _ =
+ readsSingleFieldRecordWith rp "Par1" "unPar1" Par1
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance Eq1 f => Eq1 (Rec1 f) where
+ liftEq eq = \(Rec1 a) (Rec1 a') -> liftEq eq a a'
+
+-- | @since base-4.21.0.0
+instance Ord1 f => Ord1 (Rec1 f) where
+ liftCompare cmp = \(Rec1 a) (Rec1 a') -> liftCompare cmp a a'
+
+-- | @since base-4.21.0.0
+instance Show1 f => Show1 (Rec1 f) where
+ liftShowsPrec sp sl d = \(Rec1 { unRec1 = a }) ->
+ showsSingleFieldRecordWith (liftShowsPrec sp sl) "Rec1" "unRec1" d a
+
+-- | @since base-4.21.0.0
+instance Read1 f => Read1 (Rec1 f) where
+ liftReadPrec rp rl =
+ readsSingleFieldRecordWith (liftReadPrec rp rl) "Rec1" "unRec1" Rec1
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance Eq c => Eq1 (K1 i c) where
+ liftEq _ = \(K1 a) (K1 a') -> a == a'
+
+-- | @since base-4.21.0.0
+instance Ord c => Ord1 (K1 i c) where
+ liftCompare _ = \(K1 a) (K1 a') -> compare a a'
+
+-- | @since base-4.21.0.0
+instance Show c => Show1 (K1 i c) where
+ liftShowsPrec _ _ d = \(K1 { unK1 = a }) ->
+ showsSingleFieldRecordWith showsPrec "K1" "unK1" d a
+
+-- | @since base-4.21.0.0
+instance Read c => Read1 (K1 i c) where
+ liftReadPrec _ _ = readData $
+ readsSingleFieldRecordWith readPrec "K1" "unK1" K1
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance Eq1 f => Eq1 (M1 i c f) where
+ liftEq eq = \(M1 a) (M1 a') -> liftEq eq a a'
+
+-- | @since base-4.21.0.0
+instance Ord1 f => Ord1 (M1 i c f) where
+ liftCompare cmp = \(M1 a) (M1 a') -> liftCompare cmp a a'
+
+-- | @since base-4.21.0.0
+instance Show1 f => Show1 (M1 i c f) where
+ liftShowsPrec sp sl d = \(M1 { unM1 = a }) ->
+ showsSingleFieldRecordWith (liftShowsPrec sp sl) "M1" "unM1" d a
+
+-- | @since base-4.21.0.0
+instance Read1 f => Read1 (M1 i c f) where
+ liftReadPrec rp rl = readData $
+ readsSingleFieldRecordWith (liftReadPrec rp rl) "M1" "unM1" M1
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance (Eq1 f, Eq1 g) => Eq1 (f :+: g) where
+ liftEq eq = \lhs rhs -> case (lhs, rhs) of
+ (L1 a, L1 a') -> liftEq eq a a'
+ (R1 b, R1 b') -> liftEq eq b b'
+ _ -> False
+
+-- | @since base-4.21.0.0
+instance (Ord1 f, Ord1 g) => Ord1 (f :+: g) where
+ liftCompare cmp = \lhs rhs -> case (lhs, rhs) of
+ (L1 _, R1 _) -> LT
+ (R1 _, L1 _) -> GT
+ (L1 a, L1 a') -> liftCompare cmp a a'
+ (R1 b, R1 b') -> liftCompare cmp b b'
+
+-- | @since base-4.21.0.0
+instance (Show1 f, Show1 g) => Show1 (f :+: g) where
+ liftShowsPrec sp sl d = \x -> case x of
+ L1 a -> showsUnaryWith (liftShowsPrec sp sl) "L1" d a
+ R1 b -> showsUnaryWith (liftShowsPrec sp sl) "R1" d b
+
+-- | @since base-4.21.0.0
+instance (Read1 f, Read1 g) => Read1 (f :+: g) where
+ liftReadPrec rp rl = readData $
+ readUnaryWith (liftReadPrec rp rl) "L1" L1 <|>
+ readUnaryWith (liftReadPrec rp rl) "R1" R1
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance (Eq1 f, Eq1 g) => Eq1 (f :*: g) where
+ liftEq eq = \(f :*: g) (f' :*: g') -> liftEq eq f f' && liftEq eq g g'
+
+-- | @since base-4.21.0.0
+instance (Ord1 f, Ord1 g) => Ord1 (f :*: g) where
+ liftCompare cmp = \(f :*: g) (f' :*: g') -> liftCompare cmp f f' <> liftCompare cmp g g'
+
+-- | @since base-4.21.0.0
+instance (Show1 f, Show1 g) => Show1 (f :*: g) where
+ liftShowsPrec sp sl d = \(a :*: b) ->
+ showsBinaryOpWith
+ (liftShowsPrec sp sl)
+ (liftShowsPrec sp sl)
+ 7
+ ":*:"
+ d
+ a
+ b
+
+-- | @since base-4.21.0.0
+instance (Read1 f, Read1 g) => Read1 (f :*: g) where
+ liftReadPrec rp rl = parens $ prec 6 $
+ readBinaryOpWith (liftReadPrec rp rl) (liftReadPrec rp rl) ":*:" (:*:)
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where
+ liftEq eq = \(Comp1 a) (Comp1 a') -> liftEq (liftEq eq) a a'
+
+-- | @since base-4.21.0.0
+instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where
+ liftCompare cmp = \(Comp1 a) (Comp1 a') -> liftCompare (liftCompare cmp) a a'
+
+-- | @since base-4.21.0.0
+instance (Show1 f, Show1 g) => Show1 (f :.: g) where
+ liftShowsPrec sp sl d = \(Comp1 { unComp1 = a }) ->
+ showsSingleFieldRecordWith
+ (liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl))
+ "Comp1"
+ "unComp1"
+ d
+ a
+
+-- | @since base-4.21.0.0
+instance (Read1 f, Read1 g) => Read1 (f :.: g) where
+ liftReadPrec rp rl = readData $
+ readsSingleFieldRecordWith
+ (liftReadPrec (liftReadPrec rp rl) (liftReadListPrec rp rl))
+ "Comp1"
+ "unComp1"
+ Comp1
+
+ liftReadListPrec = liftReadListPrecDefault
+ liftReadList = liftReadListDefault
+
+-- | @since base-4.21.0.0
+instance Eq1 UAddr where
+ -- NB cannot use eqAddr# because its module isn't safe
+ liftEq _ = \(UAddr a) (UAddr b) -> UAddr a == UAddr b
+
+-- | @since base-4.21.0.0
+instance Ord1 UAddr where
+ liftCompare _ = \(UAddr a) (UAddr b) -> compare (UAddr a) (UAddr b)
+
+-- | @since base-4.21.0.0
+instance Show1 UAddr where
+ liftShowsPrec _ _ = showsPrec
+
+-- NB no Read1 for URec (Ptr ()) because there's no Read for Ptr.
+
+-- | @since base-4.21.0.0
+instance Eq1 UChar where
+ liftEq _ = \(UChar a) (UChar b) -> UChar a == UChar b
+
+-- | @since base-4.21.0.0
+instance Ord1 UChar where
+ liftCompare _ = \(UChar a) (UChar b) -> compare (UChar a) (UChar b)
+
+-- | @since base-4.21.0.0
+instance Show1 UChar where
+ liftShowsPrec _ _ = showsPrec
+
+-- | @since base-4.21.0.0
+instance Eq1 UDouble where
+ liftEq _ = \(UDouble a) (UDouble b) -> UDouble a == UDouble b
+
+-- | @since base-4.21.0.0
+instance Ord1 UDouble where
+ liftCompare _ = \(UDouble a) (UDouble b) -> compare (UDouble a) (UDouble b)
+
+-- | @since base-4.21.0.0
+instance Show1 UDouble where
+ liftShowsPrec _ _ = showsPrec
+
+-- | @since base-4.21.0.0
+instance Eq1 UFloat where
+ liftEq _ = \(UFloat a) (UFloat b) -> UFloat a == UFloat b
+
+-- | @since base-4.21.0.0
+instance Ord1 UFloat where
+ liftCompare _ = \(UFloat a) (UFloat b) -> compare (UFloat a) (UFloat b)
+
+-- | @since base-4.21.0.0
+instance Show1 UFloat where
+ liftShowsPrec _ _ = showsPrec
+
+-- | @since base-4.21.0.0
+instance Eq1 UInt where
+ liftEq _ = \(UInt a) (UInt b) -> UInt a == UInt b
+
+-- | @since base-4.21.0.0
+instance Ord1 UInt where
+ liftCompare _ = \(UInt a) (UInt b) -> compare (UInt a) (UInt b)
+
+-- | @since base-4.21.0.0
+instance Show1 UInt where
+ liftShowsPrec _ _ = showsPrec
+
+-- | @since base-4.21.0.0
+instance Eq1 UWord where
+ liftEq _ = \(UWord a) (UWord b) -> UWord a == UWord b
+
+-- | @since base-4.21.0.0
+instance Ord1 UWord where
+ liftCompare _ = \(UWord a) (UWord b) -> compare (UWord a) (UWord b)
+
+-- | @since base-4.21.0.0
+instance Show1 UWord where
+ liftShowsPrec _ _ = showsPrec
+
+showsSingleFieldRecordWith :: (Int -> a -> ShowS) -> String -> String -> Int -> a -> ShowS
+showsSingleFieldRecordWith sp name field d x =
+ showParen (d > appPrec) $
+ showString name . showString " {" . showString field . showString " = " . sp 0 x . showChar '}'
+
+readsSingleFieldRecordWith :: ReadPrec a -> String -> String -> (a -> t) -> ReadPrec t
+readsSingleFieldRecordWith rp name field cons = parens $ prec 11 $ do
+ expectP $ Ident name
+ expectP $ Punc "{"
+ x <- readField field $ reset rp
+ expectP $ Punc "}"
+ pure $ cons x
+
+showsBinaryOpWith
+ :: (Int -> a -> ShowS)
+ -> (Int -> b -> ShowS)
+ -> Int
+ -> String
+ -> Int
+ -> a
+ -> b
+ -> ShowS
+showsBinaryOpWith sp1 sp2 opPrec name d x y = showParen (d >= opPrec) $
+ sp1 opPrec x . showChar ' ' . showString name . showChar ' ' . sp2 opPrec y
+
+readBinaryOpWith
+ :: ReadPrec a
+ -> ReadPrec b
+ -> String
+ -> (a -> b -> t)
+ -> ReadPrec t
+readBinaryOpWith rp1 rp2 name cons =
+ cons <$> step rp1 <* expectP (Symbol name) <*> step rp2
=====================================
libraries/ghc-internal/src/GHC/Internal/Generics.hs
=====================================
@@ -735,7 +735,7 @@ import GHC.Internal.Data.Maybe ( Maybe(..), fromMaybe )
import GHC.Internal.Data.Ord ( Down(..) )
import GHC.Num.Integer ( Integer, integerToInt )
import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )
-import GHC.Internal.Ptr ( Ptr )
+import GHC.Internal.Ptr ( Ptr(..) )
import GHC.Types
-- Needed for instances
@@ -746,7 +746,7 @@ import GHC.Internal.Base ( Alternative(..), Applicative(..), Functor(..)
import GHC.Classes ( Eq(..), Ord(..) )
import GHC.Internal.Enum ( Bounded, Enum )
import GHC.Internal.Read ( Read(..) )
-import GHC.Internal.Show ( Show(..), showString )
+import GHC.Internal.Show ( Show(..), showString, showChar, showParen, appPrec )
import GHC.Internal.Stack.Types ( SrcLoc(..) )
import GHC.Tuple (Solo (..))
import GHC.Internal.Unicode ( GeneralCategory(..) )
@@ -1037,6 +1037,14 @@ data instance URec (Ptr ()) (p :: k) = UAddr { uAddr# :: Addr# }
, Generic1 -- ^ @since base-4.9.0.0
)
+-- | @since base-4.21.0.0
+instance Show (UAddr p) where
+ -- This Show instance would be equivalent to what deriving Show would generate,
+ -- but because deriving Show doesn't support Addr# fields we define it manually.
+ showsPrec d (UAddr x) =
+ showParen (d > appPrec)
+ (\y -> showString "UAddr {uAddr# = " (showsPrec 0 (Ptr x) (showChar '}' y)))
+
-- | Used for marking occurrences of 'Char#'
--
-- @since base-4.9.0.0
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -10962,6 +10962,7 @@ instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Data.Functor.Identity.Iden
instance [safe] Data.Functor.Classes.Eq1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Classes.Eq a => Data.Functor.Classes.Eq1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Classes.Eq a, GHC.Classes.Eq b) => Data.Functor.Classes.Eq1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -10976,6 +10977,7 @@ instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Data.Functor.Identity.Ide
instance [safe] Data.Functor.Classes.Ord1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Classes.Ord a => Data.Functor.Classes.Ord1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Classes.Ord a, GHC.Classes.Ord b) => Data.Functor.Classes.Ord1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -10991,6 +10993,7 @@ instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Data.Functor.Identity.Id
instance [safe] Data.Functor.Classes.Read1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Internal.Read.Read a => Data.Functor.Classes.Read1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Internal.Read.Read a, GHC.Internal.Read.Read b) => Data.Functor.Classes.Read1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -11006,6 +11009,7 @@ instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Data.Functor.Identity.Id
instance [safe] Data.Functor.Classes.Show1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Internal.Show.Show a => Data.Functor.Classes.Show1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Internal.Show.Show a, GHC.Internal.Show.Show b) => Data.Functor.Classes.Show1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -12495,6 +12499,7 @@ instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec G
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Float p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Int p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Word p) -- Defined in ‘GHC.Internal.Generics’
+instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.UAddr p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.V1 p) -- Defined in ‘GHC.Internal.Generics’
instance GHC.Internal.Show.Show GHC.Internal.IO.Device.SeekMode -- Defined in ‘GHC.Internal.IO.Device’
instance GHC.Internal.Show.Show GHC.Internal.IO.Encoding.Types.CodingProgress -- Defined in ‘GHC.Internal.IO.Encoding.Types’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -14003,6 +14003,7 @@ instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Data.Functor.Identity.Iden
instance [safe] Data.Functor.Classes.Eq1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Classes.Eq a => Data.Functor.Classes.Eq1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Classes.Eq a, GHC.Classes.Eq b) => Data.Functor.Classes.Eq1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -14017,6 +14018,7 @@ instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Data.Functor.Identity.Ide
instance [safe] Data.Functor.Classes.Ord1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Classes.Ord a => Data.Functor.Classes.Ord1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Classes.Ord a, GHC.Classes.Ord b) => Data.Functor.Classes.Ord1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -14032,6 +14034,7 @@ instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Data.Functor.Identity.Id
instance [safe] Data.Functor.Classes.Read1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Internal.Read.Read a => Data.Functor.Classes.Read1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Internal.Read.Read a, GHC.Internal.Read.Read b) => Data.Functor.Classes.Read1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -14047,6 +14050,7 @@ instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Data.Functor.Identity.Id
instance [safe] Data.Functor.Classes.Show1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Internal.Show.Show a => Data.Functor.Classes.Show1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Internal.Show.Show a, GHC.Internal.Show.Show b) => Data.Functor.Classes.Show1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -15525,6 +15529,7 @@ instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec G
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Float p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Int p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Word p) -- Defined in ‘GHC.Internal.Generics’
+instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.UAddr p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.V1 p) -- Defined in ‘GHC.Internal.Generics’
instance GHC.Internal.Show.Show GHC.Internal.IO.Device.SeekMode -- Defined in ‘GHC.Internal.IO.Device’
instance GHC.Internal.Show.Show GHC.Internal.IO.Encoding.Types.CodingProgress -- Defined in ‘GHC.Internal.IO.Encoding.Types’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -11230,6 +11230,7 @@ instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Data.Functor.Identity.Iden
instance [safe] Data.Functor.Classes.Eq1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Classes.Eq a => Data.Functor.Classes.Eq1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Classes.Eq a, GHC.Classes.Eq b) => Data.Functor.Classes.Eq1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -11244,6 +11245,7 @@ instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Data.Functor.Identity.Ide
instance [safe] Data.Functor.Classes.Ord1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Classes.Ord a => Data.Functor.Classes.Ord1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Classes.Ord a, GHC.Classes.Ord b) => Data.Functor.Classes.Ord1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -11259,6 +11261,7 @@ instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Data.Functor.Identity.Id
instance [safe] Data.Functor.Classes.Read1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Internal.Read.Read a => Data.Functor.Classes.Read1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Internal.Read.Read a, GHC.Internal.Read.Read b) => Data.Functor.Classes.Read1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -11274,6 +11277,7 @@ instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Data.Functor.Identity.Id
instance [safe] Data.Functor.Classes.Show1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Internal.Show.Show a => Data.Functor.Classes.Show1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Internal.Show.Show a, GHC.Internal.Show.Show b) => Data.Functor.Classes.Show1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -12770,6 +12774,7 @@ instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec G
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Float p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Int p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Word p) -- Defined in ‘GHC.Internal.Generics’
+instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.UAddr p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.V1 p) -- Defined in ‘GHC.Internal.Generics’
instance GHC.Internal.Show.Show GHC.Internal.IO.Device.SeekMode -- Defined in ‘GHC.Internal.IO.Device’
instance GHC.Internal.Show.Show GHC.Internal.IO.Encoding.Types.CodingProgress -- Defined in ‘GHC.Internal.IO.Encoding.Types’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -10962,6 +10962,7 @@ instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Data.Functor.Identity.Iden
instance [safe] Data.Functor.Classes.Eq1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Eq1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Eq1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Classes.Eq a => Data.Functor.Classes.Eq1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Classes.Eq a, GHC.Classes.Eq b) => Data.Functor.Classes.Eq1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -10976,6 +10977,7 @@ instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Data.Functor.Identity.Ide
instance [safe] Data.Functor.Classes.Ord1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Ord1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Ord1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Classes.Ord a => Data.Functor.Classes.Ord1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Classes.Ord a, GHC.Classes.Ord b) => Data.Functor.Classes.Ord1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -10991,6 +10993,7 @@ instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Data.Functor.Identity.Id
instance [safe] Data.Functor.Classes.Read1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Read1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Read1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Internal.Read.Read a => Data.Functor.Classes.Read1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Internal.Read.Read a, GHC.Internal.Read.Read b) => Data.Functor.Classes.Read1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -11006,6 +11009,7 @@ instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Data.Functor.Identity.Id
instance [safe] Data.Functor.Classes.Show1 [] -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Maybe.Maybe -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Base.NonEmpty -- Defined in ‘Data.Functor.Classes’
+instance [safe] Data.Functor.Classes.Show1 GHC.Internal.Generics.Par1 -- Defined in ‘Data.Functor.Classes’
instance [safe] Data.Functor.Classes.Show1 Solo -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a. GHC.Internal.Show.Show a => Data.Functor.Classes.Show1 ((,) a) -- Defined in ‘Data.Functor.Classes’
instance [safe] forall a b. (GHC.Internal.Show.Show a, GHC.Internal.Show.Show b) => Data.Functor.Classes.Show1 ((,,) a b) -- Defined in ‘Data.Functor.Classes’
@@ -12495,6 +12499,7 @@ instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec G
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Float p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Int p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.URec GHC.Types.Word p) -- Defined in ‘GHC.Internal.Generics’
+instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.UAddr p) -- Defined in ‘GHC.Internal.Generics’
instance forall k (p :: k). GHC.Internal.Show.Show (GHC.Internal.Generics.V1 p) -- Defined in ‘GHC.Internal.Generics’
instance GHC.Internal.Show.Show GHC.Internal.IO.Device.SeekMode -- Defined in ‘GHC.Internal.IO.Device’
instance GHC.Internal.Show.Show GHC.Internal.IO.Encoding.Types.CodingProgress -- Defined in ‘GHC.Internal.IO.Encoding.Types’
=====================================
testsuite/tests/perf/should_run/T25055.hs
=====================================
@@ -0,0 +1,62 @@
+{-# OPTIONS_GHC -Wall #-}
+-- based on https://byorgey.github.io/blog/posts/2024/06/21/cpih-product-divisors.html
+
+
+import Control.Monad
+import Control.Monad.ST
+import Data.Array.ST
+import Data.Array.Unboxed
+import Data.Foldable
+
+-- This repro code turned out to be delicate wrt integer overflow
+-- See comments in #25055
+-- So, for reproducibility we use Int32, to make sure the code works on
+-- 32 bit machines with no overflow issues
+import GHC.Int
+
+smallest :: Int32 -> UArray Int32 Int32
+smallest maxN = runSTUArray $ do
+ arr <- newGenArray (2,maxN) initA
+ for_ [5, 7 .. maxN] $ \k -> do
+ k' <- readArray arr k
+ when (k == k') $ do
+ -- for type Int32 when k = 46349, k * k is negative
+ -- for_ [k*k, k*(k+2) .. maxN] $ \oddMultipleOfK -> do
+ for_ [k, k + 2 .. maxN] $ \oddMultipleOfK -> do
+ modifyArray' arr oddMultipleOfK (min k)
+ return arr
+ where
+ initA i
+ | even i = return 2
+ | i `rem` 3 == 0 = return 3
+ | otherwise = return i
+
+factor :: STUArray s Int32 Int32 -> Int32 -> Int32 -> ST s ()
+-- With #25055 the program ran slow as it appear below, but
+-- fast if you (a) comment out 'let p = smallest maxN ! m'
+-- (b) un-comment the commented-out bindings for p and sm
+factor countsArr maxN n = go n
+ where
+ -- sm = smallest maxN
+
+ go 1 = return ()
+ go m = do
+ -- let p = sm ! m
+ let p = smallest maxN ! m
+ modifyArray' countsArr p (+1)
+ go (m `div` p)
+
+
+counts :: Int32 -> [Int32] -> UArray Int32 Int32
+counts maxN ns = runSTUArray $ do
+ cs <- newArray (2,maxN) 0
+ for_ ns (factor cs maxN)
+ return cs
+
+solve :: [Int32] -> Int32
+solve = product . map (+ 1) . elems . counts 1000000
+
+main :: IO ()
+main =
+ -- print $ maximum $ elems $ smallest 1000000
+ print $ solve [1..100]
=====================================
testsuite/tests/perf/should_run/T25055.stdout
=====================================
@@ -0,0 +1 @@
+1188495
=====================================
testsuite/tests/perf/should_run/all.T
=====================================
@@ -413,3 +413,4 @@ test('T21839r',
# perf doesn't regress further, so it is not marked as such.
test('T18964', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O'])
test('T23021', [collect_stats('bytes allocated', 1), only_ways(['normal'])], compile_and_run, ['-O2'])
+test('T25055', [collect_stats('bytes allocated', 2), only_ways(['normal'])], compile_and_run, ['-O2'])
=====================================
testsuite/tests/typecheck/should_compile/T25094.hs
=====================================
@@ -0,0 +1,98 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+
+module T29054 where
+
+
+------------------------------------------------------------------------------
+import Control.Monad.ST (ST)
+import Data.Maybe (fromMaybe)
+import Data.STRef
+import GHC.Exts (Any, reallyUnsafePtrEquality#, (==#), isTrue#)
+import Unsafe.Coerce
+import Control.Monad.ST
+
+data MutableArray s a = MutableArray
+
+newArray :: Int -> a -> ST s (MutableArray s a)
+newArray = undefined
+
+readArray :: MutableArray s a -> Int -> ST s a
+readArray = undefined
+
+writeArray :: MutableArray s a -> Int -> a -> ST s ()
+writeArray = undefined
+
+
+type Key a = Any
+
+------------------------------------------------------------------------------
+-- Type signatures
+emptyRecord :: Key a
+deletedRecord :: Key a
+keyIsEmpty :: Key a -> Bool
+toKey :: a -> Key a
+fromKey :: Key a -> a
+
+
+data TombStone = EmptyElement
+ | DeletedElement
+
+{-# NOINLINE emptyRecord #-}
+emptyRecord = unsafeCoerce EmptyElement
+
+{-# NOINLINE deletedRecord #-}
+deletedRecord = unsafeCoerce DeletedElement
+
+{-# INLINE keyIsEmpty #-}
+keyIsEmpty a = isTrue# (x# ==# 1#)
+ where
+ !x# = reallyUnsafePtrEquality# a emptyRecord
+
+{-# INLINE toKey #-}
+toKey = unsafeCoerce
+
+{-# INLINE fromKey #-}
+fromKey = unsafeCoerce
+
+
+type Bucket s k v = Key (Bucket_ s k v)
+
+------------------------------------------------------------------------------
+data Bucket_ s k v = Bucket { _bucketSize :: {-# UNPACK #-} !Int
+ , _highwater :: {-# UNPACK #-} !(STRef s Int)
+ , _keys :: {-# UNPACK #-} !(MutableArray s k)
+ , _values :: {-# UNPACK #-} !(MutableArray s v)
+ }
+
+
+------------------------------------------------------------------------------
+emptyWithSize :: Int -> ST s (Bucket s k v)
+emptyWithSize !sz = undefined
+
+------------------------------------------------------------------------------
+expandArray :: a -- ^ default value
+ -> Int -- ^ new size
+ -> Int -- ^ number of elements to copy
+ -> MutableArray s a -- ^ old array
+ -> ST s (MutableArray s a)
+expandArray def !sz !hw !arr = undefined
+
+------------------------------------------------------------------------------
+growBucketTo :: Int -> Bucket s k v -> ST s (Bucket s k v)
+growBucketTo !sz bk | keyIsEmpty bk = emptyWithSize sz
+ | otherwise = do
+ if osz >= sz
+ then return bk
+ else do
+ hw <- readSTRef hwRef
+ k' <- expandArray undefined sz hw keys
+ v' <- expandArray undefined sz hw values
+ return $ toKey $ Bucket sz hwRef k' v'
+
+ where
+ bucket = fromKey bk
+ osz = _bucketSize bucket
+ hwRef = _highwater bucket
+ keys = _keys bucket
+ values = _values bucket
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -919,4 +919,4 @@ test('T23739a', normal, compile, [''])
test('T24810', normal, compile, [''])
test('T24887', normal, compile, [''])
test('T24938a', normal, compile, [''])
-
+test('T25094', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba7af8627667d8d6d1894ed88a8b1961d72a7fca...6a13e67250ef1b3ea96faef046bc4f15b5ea20ff
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba7af8627667d8d6d1894ed88a8b1961d72a7fca...6a13e67250ef1b3ea96faef046bc4f15b5ea20ff
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/20240724/241983b5/attachment-0001.html>
More information about the ghc-commits
mailing list