[Git][ghc/ghc][wip/T25096] 8 commits: Revert "Allow non-absolute values for bootstrap GHC variable"
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Jul 25 12:00:36 UTC 2024
Simon Peyton Jones pushed to branch wip/T25096 at Glasgow Haskell Compiler / GHC
Commits:
1fa35b64 by Andreas Klebinger at 2024-07-19T17:35:20+02:00
Revert "Allow non-absolute values for bootstrap GHC variable"
This broke configure in subtle ways resulting in #25076 where hadrian
didn't end up the boot compiler it was configured to use.
This reverts commit 209d09f52363b261b900cf042934ae1e81e2caa7.
- - - - -
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.
- - - - -
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
- - - - -
8bc53240 by Simon Peyton Jones at 2024-07-25T12:58:59+01:00
Fix nasty bug in occurrence analyser
As #25096 showed, the occurrence analyser was getting one-shot info
flat out wrong.
This commit fixes the bug and actually makes the code a bit tidier too.
- - - - -
b9e79e92 by Simon Peyton Jones at 2024-07-25T12:58:59+01:00
Wibble
- - - - -
1f147ad1 by Simon Peyton Jones at 2024-07-25T12:58:59+01:00
Do a bit less demand-zapping when floating
See Note [Zapping demand info when floating] in GHC.Core.Opt.SetLevels
- - - - -
63830f45 by Simon Peyton Jones at 2024-07-25T12:58:59+01:00
Wibbles
- - - - -
28 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Utils/Outputable.hs
- configure.ac
- 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/simplCore/should_run/T25096.hs
- + testsuite/tests/simplCore/should_run/T25096.stdout
- testsuite/tests/simplCore/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/DmdAnal.hs
=====================================
@@ -1039,10 +1039,10 @@ dmdTransform env var sd
TopLevel
| isInterestingTopLevelFn var
-- Top-level things will be used multiple times or not at
- -- all anyway, hence the multDmd below: It means we don't
+ -- all anyway, hence the `floatifyDmd`: it means we don't
-- have to track whether @var@ is used strictly or at most
- -- once, because ultimately it never will.
- -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness
+ -- once, because ultimately it never will
+ -> addVarDmd fn_ty var (floatifyDmd (C_11 :* sd))
| otherwise
-> fn_ty -- don't bother tracking; just annotate with 'topDmd' later
-- Everything else:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1035,8 +1035,6 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
| otherwise
= (adj_rhs_uds : adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )
where
- is_join_point = isJoinPoint mb_join
-
--------- Right hand side ---------
-- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have
-- join j = Just (f x) in ...
@@ -1044,12 +1042,9 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
-- let y = f x in join j = Just y in ...
-- That's that OccRhs would do; but there's no point because
-- j will never be scrutinised.
- env1 | is_join_point = setTailCtxt env
- | otherwise = setNonTailCtxt rhs_ctxt env -- Zap occ_join_points
+ rhs_env = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs
rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf
- -- See Note [Sources of one-shot information]
- rhs_env = addOneShotsFromDmd bndr env1
-- See Note [Join arity prediction based on joinRhsArity]
-- Match join arity O from mb_join_arity with manifest join arity M as
-- returned by of occAnalLamTail. It's totally OK for them to mismatch;
@@ -1059,16 +1054,15 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
final_bndr_with_rules
| noBinderSwaps env = bndr -- See Note [Unfoldings and rules]
| otherwise = bndr `setIdSpecialisation` mkRuleInfo rules'
- `setIdUnfolding` unf2
+ `setIdUnfolding` unf1
final_bndr_no_rules
| noBinderSwaps env = bndr -- See Note [Unfoldings and rules]
- | otherwise = bndr `setIdUnfolding` unf2
+ | otherwise = bndr `setIdUnfolding` unf1
--------- Unfolding ---------
-- See Note [Join points and unfoldings/rules]
unf = idUnfolding bndr
WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf
- unf2 = markNonRecUnfoldingOneShots mb_join unf1
adj_unf_uds = adjustTailArity mb_join unf_tuds
--------- Rules ---------
@@ -1143,10 +1137,8 @@ occAnalRec !_ lvl
| isDeadOcc occ -- Check for dead code: see Note [Dead code]
= WUD body_uds binds
| otherwise
- = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
+ = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr
!(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
- !unf' = markNonRecUnfoldingOneShots mb_join (idUnfolding tagged_bndr)
- !bndr' = tagged_bndr `setIdUnfolding` unf'
in WUD (body_uds `andUDs` rhs_uds')
(NonRec bndr' rhs' : binds)
where
@@ -1751,10 +1743,9 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
-- Instead, do the occAnalLamTail call here and postpone adjustTailUsage
-- until occAnalRec. In effect, we pretend that the RHS becomes a
-- non-recursive join point and fix up later with adjustTailUsage.
- rhs_env | isJoinId bndr = setTailCtxt env
- | otherwise = setNonTailCtxt OccRhs env
- -- If bndr isn't an /existing/ join point, it's safe to zap the
- -- occ_join_points, because they can't occur in RHS.
+ rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs
+ -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint),
+ -- it's safe to zap the occ_join_points, because they can't occur in RHS.
WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs
-- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders
@@ -2309,20 +2300,8 @@ occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)
-{- Note [Join point RHSs]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- x = e
- join j = Just x
-
-We want to inline x into j right away, so we don't want to give
-the join point a RhsCtxt (#14137). It's not a huge deal, because
-the FloatIn pass knows to float into join point RHSs; and the simplifier
-does not float things out of join point RHSs. But it's a simple, cheap
-thing to do. See #14137.
-
-Note [Occurrences in stable unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Occurrences in stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f p = BIG
{-# INLINE g #-}
@@ -2598,7 +2577,7 @@ occAnalArgs !env fun args !one_shots
| otherwise
= case one_shots of
[] -> (env_args, []) -- Fast path; one_shots is often empty
- (os : one_shots') -> (addOneShots os env_args, one_shots')
+ (os : one_shots') -> (setOneShots os env_args, one_shots')
{-
Applications are dealt with specially because we want
@@ -2910,42 +2889,125 @@ setScrutCtxt !env alts
-- non-default alternative. That in turn influences
-- pre/postInlineUnconditionally. Grep for "occ_int_cxt"!
+{- Note [The OccEnv for a right hand side]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+How do we create the OccEnv for a RHS (in mkRhsOccEnv)?
+
+For a non-join point binding, x = rhs
+
+ * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles
+
+ * occ_join_points: zap them!
+
+ * occ_one_shots: initialise from the idDemandInfo;
+ see Note [Sources of one-shot information]
+
+For a join point binding, j x = rhs
+
+ * occ_encl: Consider
+ x = e
+ join j = Just x
+ We want to inline x into j right away, so we don't want to give the join point
+ a OccRhs (#14137); we want OccVanilla. It's not a huge deal, because the
+ FloatIn pass knows to float into join point RHSs; and the simplifier does not
+ float things out of join point RHSs. But it's a simple, cheap thing to do.
+
+ * occ_join_points: no need to zap.
+
+ * occ_one_shots: we start with one-shot-info from the context, which indeed
+ applies to the /body/ of the join point, after walking past the binders.
+ So we add to the front a OneShotInfo for each value-binder of the join
+ point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point
+ binders caused #25096.)
+
+ For the join point binders themselves, of a /non-recursive/ join point,
+ we make the binder a OneShotLam. Again see `extendOneShotsForJoinPoint`.
+
+ These one-shot infos then get attached to the binder by `occAnalLamTail`.
+-}
+
setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv
setNonTailCtxt ctxt !env
= env { occ_encl = ctxt
, occ_one_shots = []
- , occ_join_points = zapped_jp_env }
- where
- -- zapped_jp_env is basically just emptyVarEnv (hence zapped). See (W3) of
- -- Note [Occurrence analysis for join points] Zapping improves efficiency,
- -- slightly, if you accidentally introduce a bug, in which you zap [jx :-> uds] and
- -- then find an occurrence of jx anyway, you might lose those uds, and
- -- that might mean we don't record all occurrencs, and that means we
- -- duplicate a redex.... a very nasty bug (which I encountered!). Hence
- -- this DEBUG code which doesn't remove jx from the envt; it just gives it
- -- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch
- -- this bug before it does any damage.
-#ifdef DEBUG
- zapped_jp_env = mapVarEnv (\ _ -> emptyVarEnv) (occ_join_points env)
-#else
- zapped_jp_env = emptyVarEnv
-#endif
+ , occ_join_points = zapJoinPointInfo (occ_join_points env) }
setTailCtxt :: OccEnv -> OccEnv
-setTailCtxt !env
- = env { occ_encl = OccVanilla }
+setTailCtxt !env = env { occ_encl = OccVanilla }
-- Preserve occ_one_shots, occ_join points
-- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):
- -- see Note [Join point RHSs]
-addOneShots :: OneShots -> OccEnv -> OccEnv
-addOneShots os !env
+mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv
+-- See Note [The OccEnv for a right hand side]
+-- For a join point:
+-- - Keep occ_one_shots, occ_joinPoints from the context
+-- - But push enough OneShotInfo onto occ_one_shots to account
+-- for the join-point value binders
+-- - Set occ_encl to OccVanilla
+-- For non-join points
+-- - Zap occ_one_shots and occ_join_points
+-- - Set occ_encl to specified OccEncl
+mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points })
+ is_rec encl jp_hood bndr rhs
+ | JoinPoint join_arity <- jp_hood
+ = env { occ_encl = OccVanilla
+ , occ_one_shots = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots
+ , occ_join_points = ctxt_join_points }
+
+ | otherwise
+ = env { occ_encl = encl
+ , occ_one_shots = argOneShots (idDemandInfo bndr)
+ -- argOneShots: see Note [Sources of one-shot information]
+ , occ_join_points = zapJoinPointInfo ctxt_join_points }
+
+zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo
+-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped).
+-- See (W3) of Note [Occurrence analysis for join points]
+--
+-- Zapping improves efficiency, slightly, if you accidentally introduce a bug,
+-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you
+-- might lose those uds, and that might mean we don't record all occurrencs, and
+-- that means we duplicate a redex.... a very nasty bug (which I encountered!).
+-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it
+-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this
+-- bug before it does any damage.
+#ifdef DEBUG
+zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info
+#else
+zapJoinPointInfo _ = emptyVarEnv
+#endif
+
+extendOneShotsForJoinPoint
+ :: RecFlag -> JoinArity -> CoreExpr
+ -> [OneShotInfo] -> [OneShotInfo]
+-- Push enough OneShortInfos on the front of ctxt_one_shots
+-- to account for the value lambdas of the join point
+extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots
+ = go join_arity rhs
+ where
+ -- For a /non-recursive/ join point we can mark all
+ -- its join-lambda as one-shot; and it's a good idea to do so
+ -- But not so for recursive ones
+ os = case is_rec of
+ NonRecursive -> OneShotLam
+ Recursive -> NoOneShotInfo
+
+ go 0 _ = ctxt_one_shots
+ go n (Lam b rhs)
+ | isId b = os : go (n-1) rhs
+ | otherwise = go (n-1) rhs
+ go _ _ = [] -- Not enough lambdas. This can legitimately happen.
+ -- e.g. let j = case ... in j True
+ -- This will become an arity-1 join point after the
+ -- simplifier has eta-expanded it; but it may not have
+ -- enough lambdas /yet/. (Lint checks that JoinIds do
+ -- have enough lambdas.)
+
+setOneShots :: OneShots -> OccEnv -> OccEnv
+setOneShots os !env
| null os = env -- Fast path for common case
| otherwise = env { occ_one_shots = os }
-addOneShotsFromDmd :: Id -> OccEnv -> OccEnv
-addOneShotsFromDmd bndr = addOneShots (argOneShots (idDemandInfo bndr))
-
isRhsEnv :: OccEnv -> Bool
isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
OccRhs -> True
@@ -3732,17 +3794,10 @@ adjustNonRecRhs :: JoinPointHood
-> WithUsageDetails CoreExpr
-- ^ This function concentrates shared logic between occAnalNonRecBind and the
-- AcyclicSCC case of occAnalRec.
--- * It applies 'markNonRecJoinOneShots' to the RHS
--- * and returns the adjusted rhs UsageDetails combined with the body usage
+-- It returns the adjusted rhs UsageDetails combined with the body usage
adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs)
- = WUD rhs_uds' rhs'
- where
- --------- Marking (non-rec) join binders one-shot ---------
- !rhs' | JoinPoint ja <- mb_join_arity = markNonRecJoinOneShots ja rhs
- | otherwise = rhs
+ = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs
- --------- Adjusting right-hand side usage ---------
- rhs_uds' = adjustTailUsage mb_join_arity rhs_wuds
adjustTailUsage :: JoinPointHood
-> WithTailUsageDetails CoreExpr -- Rhs usage, AFTER occAnalLamTail
@@ -3760,33 +3815,6 @@ adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity mb_rhs_ja (TUD ja usage)
= markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage
-markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
--- For a /non-recursive/ join point we can mark all
--- its join-lambda as one-shot; and it's a good idea to do so
-markNonRecJoinOneShots join_arity rhs
- = go join_arity rhs
- where
- go 0 rhs = rhs
- go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b)
- (go (n-1) rhs)
- go _ rhs = rhs -- Not enough lambdas. This can legitimately happen.
- -- e.g. let j = case ... in j True
- -- This will become an arity-1 join point after the
- -- simplifier has eta-expanded it; but it may not have
- -- enough lambdas /yet/. (Lint checks that JoinIds do
- -- have enough lambdas.)
-
-markNonRecUnfoldingOneShots :: JoinPointHood -> Unfolding -> Unfolding
--- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding
-markNonRecUnfoldingOneShots mb_join_arity unf
- | JoinPoint ja <- mb_join_arity
- , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf
- , isStableSource src
- , let !tmpl' = markNonRecJoinOneShots ja tmpl
- = unf{uf_tmpl=tmpl'}
- | otherwise
- = unf
-
type IdWithOccInfo = Id
tagLamBinders :: UsageDetails -- Of scope
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1874,7 +1874,6 @@ cloneLetVars is_rec
env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
dest_lvl vs
= do { let vs1 = map zap vs
- -- See Note [Zapping the demand info]
; (subst', vs2) <- case is_rec of
NonRecursive -> cloneBndrs subst vs1
Recursive -> cloneRecIdBndrs subst vs1
@@ -1887,9 +1886,12 @@ cloneLetVars is_rec
; return (env', vs2) }
where
zap :: Var -> Var
- zap v | isId v = zap_join (zapIdDemandInfo v)
+ -- See Note [Floatifying demand info when floating]
+ -- and Note [Zapping JoinId when floating]
+ zap v | isId v = zap_join (floatifyIdDemandInfo v)
| otherwise = v
+ -- See Note [Zapping JoinId when floating]
zap_join | isTopLvl dest_lvl = zapJoinId
| otherwise = id
@@ -1898,16 +1900,38 @@ add_id id_env (v, v1)
| isTyVar v = delVarEnv id_env v
| otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)
-{-
-Note [Zapping the demand info]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-VERY IMPORTANT: we must zap the demand info if the thing is going to
-float out, because it may be less demanded than at its original
-binding site. Eg
- f :: Int -> Int
- f x = let v = 3*4 in v+x
-Here v is strict; but if we float v to top level, it isn't any more.
-
-Similarly, if we're floating a join point, it won't be one anymore, so we zap
-join point information as well.
+{- Note [Zapping JoinId when floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we are floating a join point, it won't be one anymore, so we zap
+the join point information.
+
+Note [Floatifying demand info when floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When floating we must lazify the outer demand info on the Id
+because it may be less demanded than at its original binding site.
+For example:
+ f :: Int -> Int
+ f x = let v = 3*4 in v+x
+Here v is strict and used at most once; but if we float v to top level,
+that isn't true any more. Specifically, we lose track of v's cardinality info:
+ * if `f` is called multiple times, then `v` is used more than once
+ * if `f` is never called, then `v` is never evaluated.
+
+But NOTE that we only need to adjust the /top-level/ cardinality info.
+For example
+ let x = (e1,e2)
+ in ...(case x of (a,b) -> a+b)...
+If we float x outwards, it may no longer be strict, but IF it is ever
+evaluated THEN its components will be evaluated. So we to lazify and
+many-ify its demand-info, not discard it entirely.
+
+Same if we have
+ let f = \x y . blah
+ in ...(f a b)...(f c d)...
+Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can
+keep that `1C` called-once inner demand. It's only the outer strictness
+that we kill.
+
+Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the
+fact that `v` may be used any number of times, from zero upwards.
-}
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -971,7 +971,7 @@ addLetBndrInfo new_bndr new_arity_type new_unf
-- Demand info: Note [Setting the demand info]
info3 | isEvaldUnfolding new_unf
- = zapDemandInfo info2 `orElse` info2
+ = lazifyDemandInfo info2 `orElse` info2
| otherwise
= info2
@@ -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/Opt/Specialise.hs
=====================================
@@ -1485,11 +1485,12 @@ specBind top_lvl env (NonRec fn rhs) do_body
-- This is important: see Note [Update unfolding after specialisation]
-- And in any case cloneBndrSM discards non-Stable unfoldings
- fn3 = zapIdDemandInfo fn2
+ fn3 = floatifyIdDemandInfo fn2
-- We zap the demand info because the binding may float,
-- which would invalidate the demand info (see #17810 for example).
-- Destroying demand info is not terrible; specialisation is
-- always followed soon by demand analysis.
+ -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels
body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds
`extendInScope` fn3
=====================================
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.
+-}
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -38,7 +38,7 @@ module GHC.Types.Demand (
-- *** Demands used in PrimOp signatures
lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
-- ** Other @Demand@ operations
- oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd,
+ oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, floatifyDmd,
peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, strictCallArity,
mkWorkerDemand, subDemandIfEvaluated,
-- ** Extracting one-shot information
@@ -608,22 +608,22 @@ multCard (Card a) (Card b)
--
-- Examples (using Note [Demand notation]):
--
--- * 'seq' puts demand @1A@ on its first argument: It evaluates the argument
--- strictly (@1@), but not any deeper (@A@).
--- * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument
+-- * 'seq' puts demand `1A` on its first argument: It evaluates the argument
+-- strictly (`1`), but not any deeper (`A`).
+-- * 'fst' puts demand `1P(1L,A)` on its argument: It evaluates the argument
-- pair strictly and the first component strictly, but no nested info
--- beyond that (@L@). Its second argument is not used at all.
--- * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the
--- argument function with one argument, exactly once (@1@). No info
--- on how the result of that call is evaluated (@L@).
--- * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates
+-- beyond that (`L`). Its second argument is not used at all.
+-- * '$' puts demand `1C(1,L)` on its first argument: It calls (`C`) the
+-- argument function with one argument, exactly once (`1`). No info
+-- on how the result of that call is evaluated (`L`).
+-- * 'maybe' puts demand `MC(M,L)` on its second argument: It evaluates
-- the argument function at most once ((M)aybe) and calls it once when
-- it is evaluated.
--- * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@
--- multiplied by two, so we get @S@ (used at least once, possibly multiple
+-- * `fst p + fst p` puts demand `SP(SL,A)` on `p`: It's `1P(1L,A)`
+-- multiplied by two, so we get `S` (used at least once, possibly multiple
-- times).
--
--- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled
+-- This data type is quite similar to `'Scaled' 'SubDemand'`, but it's scaled
-- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of
-- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and
-- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there
@@ -1013,6 +1013,11 @@ strictifyDictDmd _ dmd = dmd
lazifyDmd :: Demand -> Demand
lazifyDmd = multDmd C_01
+-- | Adjust the demand on a binding that may float outwards
+-- See Note [Floatifying demand info when floating]
+floatifyDmd :: Demand -> Demand
+floatifyDmd = multDmd C_0N
+
-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@.
mkCalledOnceDmd :: SubDemand -> SubDemand
mkCalledOnceDmd sd = mkCall C_11 sd
@@ -2651,7 +2656,12 @@ So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand',
but it's always clear from context which "overload" is meant. It's like
return-type inference of e.g. 'read'.
-Examples are in the haddock for 'Demand'.
+Examples are in the haddock for 'Demand'. Here are some more:
+ SA Strict, but does not look at subcomponents (`seq`)
+ SP(L,L) Strict boxed pair, components lazy
+ S!P(L,L) Strict unboxed pair, components lazy
+ LP(SA,SA) Lazy pair, but if it is evaluated will evaluated its components
+ LC(1C(L)) Lazy, but if called will apply the result exactly once
This is the syntax for demand signatures:
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -54,7 +54,7 @@ module GHC.Types.Id (
setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
- zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
+ zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
zapIdUsedOnceInfo, zapIdTailCallInfo,
zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding,
transferPolyIdInfo, scaleIdBy, scaleVarBy,
@@ -991,8 +991,9 @@ zapLamIdInfo = zapInfo zapLamInfo
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = zapInfo zapFragileInfo
-zapIdDemandInfo :: Id -> Id
-zapIdDemandInfo = zapInfo zapDemandInfo
+floatifyIdDemandInfo :: Id -> Id
+-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels
+floatifyIdDemandInfo = zapInfo floatifyDemandInfo
zapIdUsageInfo :: Id -> Id
zapIdUsageInfo = zapInfo zapUsageInfo
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -35,7 +35,8 @@ module GHC.Types.Id.Info (
-- ** Zapping various forms of Info
zapLamInfo, zapFragileInfo,
- zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
+ lazifyDemandInfo, floatifyDemandInfo,
+ zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
zapTailCallInfo, zapCallArityInfo, trimUnfolding,
-- ** The ArityInfo type
@@ -855,11 +856,21 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
is_safe_dmd dmd = not (isStrUsedDmd dmd)
--- | Remove all demand info on the 'IdInfo'
-zapDemandInfo :: IdInfo -> Maybe IdInfo
-zapDemandInfo info = Just (info {demandInfo = topDmd})
-
--- | Remove usage (but not strictness) info on the 'IdInfo'
+-- | Lazify (remove the top-level demand, only) the demand in `IdInfo`
+-- Keep nested demands; see Note [Floatifying demand info when floating]
+-- in GHC.Core.Opt.SetLevels
+lazifyDemandInfo :: IdInfo -> Maybe IdInfo
+lazifyDemandInfo info@(IdInfo { demandInfo = dmd })
+ = Just (info {demandInfo = lazifyDmd dmd })
+
+-- | Floatify the demand in `IdInfo`
+-- But keep /nested/ demands; see Note [Floatifying demand info when floating]
+-- in GHC.Core.Opt.SetLevels
+floatifyDemandInfo :: IdInfo -> Maybe IdInfo
+floatifyDemandInfo info@(IdInfo { demandInfo = dmd })
+ = Just (info {demandInfo = floatifyDmd dmd })
+
+-- | Remove usage (but not strictness) info on the `IdInfo`
zapUsageInfo :: IdInfo -> Maybe IdInfo
zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -1261,7 +1261,7 @@ data BindingSite
data JoinPointHood
= JoinPoint {-# UNPACK #-} !Int -- The JoinArity (but an Int here because
- | NotJoinPoint -- synonym JoinArity is defined in Types.Basic
+ | NotJoinPoint -- synonym JoinArity is defined in Types.Basic)
deriving( Eq )
isJoinPoint :: JoinPointHood -> Bool
=====================================
configure.ac
=====================================
@@ -97,11 +97,11 @@ dnl use either is considered a Feature.
dnl ** What command to use to compile compiler sources ?
dnl --------------------------------------------------------------
-AC_ARG_VAR(GHC,[Use as the bootstrap GHC. [default=autodetect]])
-AC_CHECK_PROG([GHC], [ghc], [ghc])
+AC_ARG_VAR(GHC,[Use as the full path to GHC. [default=autodetect]])
+AC_PATH_PROG([GHC], [ghc])
AC_ARG_WITH([ghc],
- AS_HELP_STRING([--with-ghc=PATH], [Use PATH as the bootstrap ghc (obsolete, use GHC=PATH instead) [default=autodetect]]),
- AC_MSG_ERROR([--with-ghc=$withval is obsolete (use './configure GHC=$withval' instead)]))
+ AS_HELP_STRING([--with-ghc=PATH], [Use PATH as the full path to ghc (obsolete, use GHC=PATH instead) [default=autodetect]]),
+ AC_MSG_ERROR([--with-ghc=$withval is obsolete (use './configure GHC=$withval' or 'GHC=$withval ./configure' instead)]))
AC_SUBST(WithGhc,$GHC)
AC_ARG_ENABLE(bootstrap-with-devel-snapshot,
=====================================
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/simplCore/should_run/T25096.hs
=====================================
@@ -0,0 +1,20 @@
+module Main where
+
+import System.IO.Unsafe
+import Control.Monad
+
+main :: IO ()
+main = do
+ foo "test" 10
+
+foo :: String -> Int -> IO ()
+foo x n = go n
+ where
+ oops = unsafePerformIO (putStrLn "Once" >> pure (cycle x))
+
+ go 0 = return ()
+ go n = do
+ -- `oops` should be shared between loop iterations
+ let p = take n oops
+ let !_ = unsafePerformIO (putStrLn p >> pure ())
+ go (n-1)
=====================================
testsuite/tests/simplCore/should_run/T25096.stdout
=====================================
@@ -0,0 +1,11 @@
+Once
+testtestte
+testtestt
+testtest
+testtes
+testte
+testt
+test
+tes
+te
+t
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -115,3 +115,4 @@ test('T23134', normal, compile_and_run, ['-O0 -fcatch-nonexhaustive-cases'])
test('T23289', normal, compile_and_run, [''])
test('T23056', [only_ways(['ghci-opt'])], ghci_script, ['T23056.script'])
test('T24725', normal, compile_and_run, ['-O -dcore-lint'])
+test('T25096', normal, compile_and_run, ['-O -dcore-lint'])
=====================================
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/10ee25c405dde42326eb4ebc82b948f36b748eff...63830f452c2b3f4c375fe0ea20acedc926ea00df
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/10ee25c405dde42326eb4ebc82b948f36b748eff...63830f452c2b3f4c375fe0ea20acedc926ea00df
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/20240725/032246d9/attachment-0001.html>
More information about the ghc-commits
mailing list