[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Define Eq1, Ord1, Show1 and Read1 instances for basic Generic representation types
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Jul 26 08:42:04 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a8362630 by Sergey Vinokurov at 2024-07-24T12:22:45-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.
- - - - -
de5d9852 by Simon Peyton Jones at 2024-07-24T12:23:22-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
- - - - -
3f89ab92 by Andreas Klebinger at 2024-07-25T14:12:54+02:00
Fix -freg-graphs for FP and AARch64 NCG (#24941).
It seems we reserve 8 registers instead of four for global regs
based on the layout in Note [AArch64 Register assignments].
I'm not sure it's neccesary, but for now we just accept this state of
affairs and simple update -fregs-graph to account for this.
- - - - -
2e64d2ac by Torsten Schmits at 2024-07-26T04:41:46-04:00
add missing cell in flavours table
- - - - -
21 changed files:
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/CmmToAsm/AArch64/Regs.hs
- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- docs/users_guide/9.12.1-notes.rst
- hadrian/doc/flavours.md
- libraries/base/changelog.md
- libraries/base/src/Data/Functor/Classes.hs
- libraries/ghc-internal/src/GHC/Internal/Generics.hs
- + testsuite/tests/codeGen/should_gen_asm/T24941.hs
- testsuite/tests/codeGen/should_gen_asm/all.T
- 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
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/Instr.hs
=====================================
@@ -177,6 +177,8 @@ regUsageOfInstr platform instr = case instr of
interesting _ (RegVirtual _) = True
interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
+-- Note [AArch64 Register assignments]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Save caller save registers
-- This is x0-x18
--
@@ -199,6 +201,8 @@ regUsageOfInstr platform instr = case instr of
-- '---------------------------------------------------------------------------------------------------------------------------------------------------------------'
-- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer
-- BR: Base, SL: SpLim
+--
+-- TODO: The zero register is currently mapped to -1 but should get it's own separate number.
callerSavedRegisters :: [Reg]
callerSavedRegisters
= map regSingle [0..18]
=====================================
compiler/GHC/CmmToAsm/AArch64/Ppr.hs
=====================================
@@ -316,6 +316,7 @@ pprReg w r = case r of
| w == W64 = text "sp"
| w == W32 = text "wsp"
+ -- See Note [AArch64 Register assignments]
ppr_reg_no w i
| i < 0, w == W32 = text "wzr"
| i < 0, w == W64 = text "xzr"
=====================================
compiler/GHC/CmmToAsm/AArch64/Regs.hs
=====================================
@@ -17,6 +17,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
+-- TODO: Should this include the zero register?
allMachRegNos :: [RegNo]
allMachRegNos = [0..31] ++ [32..63]
-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
=====================================
@@ -183,7 +183,8 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu
ArchPPC -> 26
ArchPPC_64 _ -> 20
ArchARM _ _ _ -> panic "trivColorable ArchARM"
- ArchAArch64 -> 28 -- 32 - D1..D4
+ ArchAArch64 -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use.
+ -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this.
ArchAlpha -> panic "trivColorable ArchAlpha"
ArchMipseb -> panic "trivColorable ArchMipseb"
ArchMipsel -> panic "trivColorable ArchMipsel"
=====================================
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/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.
+-}
=====================================
docs/users_guide/9.12.1-notes.rst
=====================================
@@ -78,12 +78,15 @@ Compiler
<https://gitlab.haskell.org/ghc/ghc/-/issues/24921>`_). This does
not affect existing support of apple systems on x86_64/aarch64.
-- The flag :ghc-flag:`-fignore-asserts` will now also enable the
+- The flag :ghc-flag:`-fignore-asserts` will now also enable the
:extension:`CPP` macro ``__GLASGOW_HASKELL_ASSERTS_IGNORED__`` (`#24967
<https://gitlab.haskell.org/ghc/ghc/-/issues/24967>`_).
This enables people to write their own custom assertion functions.
See :ref:`assertions`.
-
+
+- Fixed a bug that caused GHC to panic when using the aarch64 ncg and -fregs-graph
+ on certain programs. (#24941)
+
GHCi
~~~~
=====================================
hadrian/doc/flavours.md
=====================================
@@ -108,6 +108,7 @@ when compiling the `compiler` library, and `hsGhc` when compiling/linking the GH
</tr>
<tr>
<th>release (same as perf with -haddock)</td>
+ <td></td>
<td>-O<br>-H64m</td>
<td>-O<br>-H64m</td>
<td></td>
=====================================
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/codeGen/should_gen_asm/T24941.hs
=====================================
@@ -0,0 +1,23 @@
+module T24941 where
+
+data F = F
+ !Float !Float !Float !Float !Float !Float !Float !Float !Float !Float
+ !Float !Float !Float !Float !Float !Float !Float !Float !Float !Float
+ !Float !Float !Float !Float !Float !Float !Float !Float !Float !Float
+ !Float !Float
+
+
+foo ( F
+ x00 x01 x02 x03 x04 x05 x06 x07 x08 x09
+ x10 x11 x12 x13 x14 x15 x16 x17 x18 x19
+ x20 x21 x22 x23 x24 x25 x26 x27 x28 x29
+ x30 x31
+ )
+ =
+
+ F
+ x00 x01 x02 x03 x04 x05 x06 x07 x08 x09
+ x10 x11 x12 x13 x14 x15 x16 x17 x18 x19
+ x20 x21 x22 x23 x24 x25 x26 x27 x28 x29
+
+ x30 (x31+1)
\ No newline at end of file
=====================================
testsuite/tests/codeGen/should_gen_asm/all.T
=====================================
@@ -10,3 +10,5 @@ test('memset-unroll', is_amd64_codegen, compile_cmp_asm, ['cmm', ''])
test('bytearray-memset-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True, ''])
test('bytearray-memcpy-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True, ''])
test('T18137', [when(opsys('darwin'), skip), only_ways(llvm_ways)], compile_grep_asm, ['hs', False, '-fllvm -split-sections'])
+
+test('T24941', [only_ways(['optasm'])], compile, ['-fregs-graph'])
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a13e67250ef1b3ea96faef046bc4f15b5ea20ff...2e64d2ac7fd7a832bfe5e19b5475e41fab979d47
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a13e67250ef1b3ea96faef046bc4f15b5ea20ff...2e64d2ac7fd7a832bfe5e19b5475e41fab979d47
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/20240726/38b74186/attachment-0001.html>
More information about the ghc-commits
mailing list