[Git][ghc/ghc][wip/romes/pccdesc] 6 commits: Revert "Allow non-absolute values for bootstrap GHC variable"
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Fri Jul 26 13:15:06 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/pccdesc 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
- - - - -
452e82df by Rodrigo Mesquita at 2024-07-26T13:14:51+00:00
Refactor ProfilingInfo to preserve Unique information before rendering it
- - - - -
3869ecbb by Rodrigo Mesquita at 2024-07-26T13:14:51+00:00
fixup! Refactor ProfilingInfo to preserve Unique information before rendering it
- - - - -
24 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Closure.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/typecheck/should_compile/T25094.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -29,7 +29,7 @@ module GHC.Cmm (
-- * Info Tables
CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
ClosureTypeInfo(..),
- ProfilingInfo(..), ConstrDescription,
+ ProfilingInfo(..), renderProfInfo, ConstrDescription,
-- * Statements, expressions and types
module GHC.Cmm.Node,
@@ -40,8 +40,13 @@ module GHC.Cmm (
) where
import GHC.Prelude
+import GHC.Utils.Panic (pprPanic)
import GHC.Platform
+import GHC.Core.TyCo.Rep
+import GHC.Tc.Utils.TcType (tcSplitSigmaTy)
+import GHC.Unit.Types (Module)
+import GHC.Types.Name (Name, pprFullName, getOccString)
import GHC.Types.Id
import GHC.Types.CostCentre
import GHC.Cmm.CLabel
@@ -57,7 +62,6 @@ import GHC.Utils.Outputable
import Data.Void (Void)
import Data.List (intersperse)
import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-----------------------------------------------------------------------------
-- Cmm, GenCmm
@@ -233,10 +237,73 @@ data CmmInfoTable
instance OutputableP Platform CmmInfoTable where
pdoc = pprInfoTable
+-----------------------------------------------------------------------------
+-- Profiling
+-----------------------------------------------------------------------------
+
data ProfilingInfo
= NoProfilingInfo
- | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
+ | ClosureProfilingInfo Module Id -- this_module, closure_id
+ | DataProfilingInfo Name Name -- datacon_tycon_name, datacon_name
+ | ParsedProfilingInfo String String
+ -- ^ Construct profiling info directly with the description and type strings (as in Cmm.Parser)
+ -- Note that if these strings leak non-deterministic uniques those will
+ -- ultimately leak into the object files regardless of the renaming pass.
+ -- In the parser they are stable since they're parsed directly as strings.
deriving (Eq, Ord)
+
+-- | Render the profiling information as strings from a 'ProfilingInfo':
+-- the first string is the type and the second is the description.
+renderProfInfo :: ProfilingInfo -> Maybe (String {- type -}, String {- description -})
+renderProfInfo NoProfilingInfo = Nothing
+renderProfInfo (ClosureProfilingInfo mod_name id) = Just (ty_descr, val_descr)
+ where
+ ty_descr = getTyDescription (idType id)
+ val_descr = closureDescription mod_name (idName id)
+renderProfInfo (DataProfilingInfo datacon_tycon_name datacon_name) = Just (ty_descr, val_descr)
+ where
+ ty_descr = getOccString datacon_tycon_name
+ val_descr = getOccString datacon_name
+renderProfInfo (ParsedProfilingInfo ty_descr val_descr) = Just (ty_descr, val_descr)
+
+-- For "global" data constructors the description is simply occurrence
+-- name of the data constructor itself. Otherwise it is determined by
+-- @closureDescription@ from the let binding information.
+
+closureDescription
+ :: Module -- Module
+ -> Name -- Id of closure binding
+ -> String
+ -- Not called for StgRhsCon which have global info tables built in
+ -- CgConTbls.hs with a description generated from the data constructor
+closureDescription mod_name name
+ = showSDocOneLine defaultSDocContext
+ (char '<' <> pprFullName mod_name name <> char '>')
+
+getTyDescription :: Type -> String
+getTyDescription ty
+ = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+ case tau_ty of
+ TyVarTy _ -> "*"
+ AppTy fun _ -> getTyDescription fun
+ TyConApp tycon _ -> getOccString tycon
+ FunTy {} -> '-' : fun_result tau_ty
+ ForAllTy _ ty -> getTyDescription ty
+ LitTy n -> getTyLitDescription n
+ CastTy ty _ -> getTyDescription ty
+ CoercionTy co -> pprPanic "getTyDescription" (ppr co)
+ }
+ where
+ fun_result (FunTy { ft_res = res }) = '>' : fun_result res
+ fun_result other = getTyDescription other
+
+getTyLitDescription :: TyLit -> String
+getTyLitDescription l =
+ case l of
+ NumTyLit n -> show n
+ StrTyLit n -> show n
+ CharTyLit n -> show n
+
-----------------------------------------------------------------------------
-- Static Data
-----------------------------------------------------------------------------
@@ -431,11 +498,11 @@ pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
, cit_srt = srt })
= vcat [ text "label: " <> pdoc platform lbl
, text "rep: " <> ppr rep
- , case prof_info of
- NoProfilingInfo -> empty
- ProfilingInfo ct cd ->
- vcat [ text "type: " <> text (show (BS.unpack ct))
- , text "desc: " <> text (show (BS.unpack cd)) ]
+ , case renderProfInfo prof_info of
+ Nothing -> empty
+ Just (ct, cd) ->
+ vcat [ text "type: " <> text (show ct)
+ , text "desc: " <> text (show cd) ]
, text "srt: " <> pdoc platform srt ]
-- --------------------------------------------------------------------------
=====================================
compiler/GHC/Cmm/Info.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS8
-- When we split at proc points, we need an empty info table.
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
@@ -413,11 +414,12 @@ mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit
-------------------------------------------------------------------------
mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
-mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), [])
-mkProfLits _ (ProfilingInfo td cd)
- = do { (td_lit, td_decl) <- newStringLit td
- ; (cd_lit, cd_decl) <- newStringLit cd
- ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
+mkProfLits platform profInfo = case renderProfInfo profInfo of
+ Nothing -> return ((zeroCLit platform, zeroCLit platform), [])
+ Just (td, cd)
+ -> do { (td_lit, td_decl) <- newStringLit (BS8.pack td)
+ ; (cd_lit, cd_decl) <- newStringLit (BS8.pack cd)
+ ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit bytes
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -609,7 +609,6 @@ cafLattice = DataflowLattice Set.empty add
let !new' = old `Set.union` new
in changedIf (Set.size new' > Set.size old) new'
-
cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers platform contLbls entry topLbl
block@(BlockCC eNode middle xNode) fBase =
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1328,7 +1328,7 @@ reserveStackFrame psize preg body = do
profilingInfo profile desc_str ty_str
= if not (profileIsProfiling profile)
then NoProfilingInfo
- else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
+ else ParsedProfilingInfo desc_str ty_str
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
=====================================
compiler/GHC/CmmToAsm/Reg/Linear.hs
=====================================
@@ -644,7 +644,6 @@ releaseRegs regs = do
_ -> loop (delFromUFM assig r) free rs
loop assig free regs
-
-- -----------------------------------------------------------------------------
-- Clobber real registers
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -860,7 +860,7 @@ data ArityOpts = ArityOpts
-- | The Arity returned is the number of value args the
-- expression can be applied to without doing much work
-exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType
+exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType
-- exprEtaExpandArity is used when eta expanding
-- e ==> \xy -> e x y
-- Nothing if the expression has arity 0
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2342,34 +2342,44 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_cont = cont, sc_hole_ty = fun_ty })
| fun_id `hasKey` runRWKey
- , [ TyArg {}, TyArg {} ] <- rev_args
- -- Do this even if (contIsStop cont)
+ , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args
+ -- Do this even if (contIsStop cont), or if seCaseCase is off.
-- See Note [No eta-expansion in runRW#]
= do { let arg_env = arg_se `setInScopeFromE` env
- ty' = contResultType cont
+
+ overall_res_ty = contResultType cont
+ -- hole_ty is the type of the current runRW# application
+ (outer_cont, new_runrw_res_ty, inner_cont)
+ | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont)
+ | otherwise = (cont, hole_ty, mkBoringStop hole_ty)
+ -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
+ -- Note [Case-of-case and full laziness]
-- If the argument is a literal lambda already, take a short cut
- -- This isn't just efficiency; if we don't do this we get a beta-redex
- -- every time, so the simplifier keeps doing more iterations.
+ -- This isn't just efficiency:
+ -- * If we don't do this we get a beta-redex every time, so the
+ -- simplifier keeps doing more iterations.
+ -- * Even more important: see Note [No eta-expansion in runRW#]
; arg' <- case arg of
Lam s body -> do { (env', s') <- simplBinder arg_env s
- ; body' <- simplExprC env' body cont
+ ; body' <- simplExprC env' body inner_cont
; return (Lam s' body') }
-- Important: do not try to eta-expand this lambda
-- See Note [No eta-expansion in runRW#]
+
_ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
; let (m,_,_) = splitFunTy fun_ty
env' = arg_env `addNewInScopeIds` [s']
cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'
- , sc_env = env', sc_cont = cont
- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
+ , sc_env = env', sc_cont = inner_cont
+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }
-- cont' applies to s', then K
; body' <- simplExprC env' arg cont'
; return (Lam s' body') }
- ; let rr' = getRuntimeRep ty'
- call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']
- ; return (emptyFloats env, call') }
+ ; let rr' = getRuntimeRep new_runrw_res_ty
+ call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']
+ ; rebuild env call' outer_cont }
---------- Simplify value arguments --------------------
rebuildCall env fun_info
@@ -2382,7 +2392,8 @@ rebuildCall env fun_info
-- Strict arguments
| isStrictArgInfo fun_info
- , seCaseCase env
+ , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
+ -- Note [Case-of-case and full laziness]
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setInScopeFromE` env) arg
(StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
@@ -3195,7 +3206,9 @@ doCaseToLet scrut case_bndr
--------------------------------------------------
reallyRebuildCase env scrut case_bndr alts cont
- | not (seCaseCase env)
+ | not (seCaseCase env) -- Only when case-of-case is on.
+ -- See GHC.Driver.Config.Core.Opt.Simplify
+ -- Note [Case-of-case and full laziness]
= do { case_expr <- simplAlts env scrut case_bndr alts
(mkBoringStop (contHoleType cont))
; rebuild env case_expr cont }
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -2315,22 +2315,27 @@ buildSynTyCon name binders res_kind roles rhs
where
is_tau = isTauTy rhs
is_fam_free = isFamFreeTy rhs
+ expanded_rhs = expandTypeSynonyms rhs
+
is_concrete = uniqSetAll isConcreteTyCon rhs_tycons
- -- NB: is_concrete is allowed to be conservative, returning False
- -- more often than it could. e.g.
+ rhs_tycons = tyConsOfType expanded_rhs
+ -- NB: we look at expanded_rhs e.g.
-- type S a b = b
-- type family F a
-- type T a = S (F a) a
- -- We will mark T as not-concrete, even though (since S ignore its first
- -- argument, it could be marked concrete.
-
- is_forgetful = not (all ((`elemVarSet` rhs_tyvars) . binderVar) binders) ||
- uniqSetAny isForgetfulSynTyCon rhs_tycons
- -- NB: is_forgetful is allowed to be conservative, returning True more often
- -- than it should. See Note [Forgetful type synonyms] in GHC.Core.TyCon
-
- rhs_tycons = tyConsOfType rhs
- rhs_tyvars = tyCoVarsOfType rhs
+ -- We want to mark T as concrete, because S ignores its first argument
+
+ is_forgetful = not (all ((`elemVarSet` expanded_rhs_tyvars) . binderVar) binders)
+ expanded_rhs_tyvars = tyCoVarsOfType expanded_rhs
+ -- See Note [Forgetful type synonyms] in GHC.Core.TyCon
+ -- To find out if this TyCon is forgetful, expand the synonyms in its RHS
+ -- and check that all of the binders are free in the expanded type.
+ -- We really only need to expand the /forgetful/ synonyms on the RHS,
+ -- but we don't currently have a function to do that.
+ -- Failing to expand the RHS led to #25094, e.g.
+ -- type Bucket a b c = Key (a,b,c)
+ -- type Key x = Any
+ -- Here Bucket is definitely forgetful!
{-
************************************************************************
=====================================
compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
=====================================
@@ -80,6 +80,7 @@ initGentleSimplMode :: DynFlags -> SimplMode
initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")
{ -- Don't do case-of-case transformations.
-- This makes full laziness work better
+ -- See Note [Case-of-case and full laziness]
sm_case_case = False
}
@@ -89,3 +90,37 @@ floatEnable dflags =
(True, True) -> FloatEnabled
(True, False)-> FloatNestedOnly
(False, _) -> FloatDisabled
+
+
+{- Note [Case-of-case and full laziness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case-of-case can hide opportunities for let-floating (full laziness).
+For example
+ rec { f = \y. case (expensive x) of (a,b) -> blah }
+We might hope to float the (expensive x) out of the \y-loop.
+But if we inline `expensive` we might get
+ \y. case (case x of I# x' -> body) of (a,b) -> blah
+Now if we do case-of-case we get
+ \y. case x if I# x2 ->
+ case body of (a,b) -> blah
+
+Sadly, at this point `body` mentions `x2`, so we can't float it out of the
+\y-loop.
+
+Solution: don't do case-of-case in the "gentle" simplification phase that
+precedes the first float-out transformation. Implementation:
+
+ * `sm_case_case` field in SimplMode
+
+ * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case
+ in GHC.Core.Opt.Simplify.Iteration.rebuildCall.
+
+Wrinkles
+
+* This applies equally to the case-of-runRW# transformation:
+ case (runRW# (\s. body)) of (a,b) -> blah
+ --->
+ runRW# (\s. case body of (a,b) -> blah)
+ Again, don't do this when `sm_case_case` is off. See #25055 for
+ a motivating example.
+-}
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -18,7 +18,6 @@ import GHC.Prelude hiding ((<*>))
import GHC.Core ( AltCon(..) )
import GHC.Core.Opt.Arity( isOneShotBndr )
import GHC.Runtime.Heap.Layout
-import GHC.Unit.Module
import GHC.Stg.Syntax
@@ -53,7 +52,6 @@ import GHC.Stg.Utils
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Tickish ( tickishIsCode )
@@ -130,10 +128,8 @@ cgTopRhsClosure platform rec id ccs upd_flag args body =
gen_code lf_info _closure_label
= do { profile <- getProfile
- ; let name = idName id
; mod_name <- getModuleName
- ; let descr = closureDescription mod_name name
- closure_info = mkClosureInfo profile True id lf_info 0 0 descr
+ ; let closure_info = mkClosureInfo profile True id lf_info 0 0 mod_name
-- We don't generate the static closure here, because we might
-- want to add references to static closures to it later. The
@@ -423,15 +419,13 @@ mkRhsClosure profile _use_ap _check_tags bndr cc fvs upd_flag args body
-- MAKE CLOSURE INFO FOR THIS CLOSURE
; mod_name <- getModuleName
- ; let name = idName bndr
- descr = closureDescription mod_name name
- fv_details :: [(NonVoid Id, ByteOff)]
+ ; let fv_details :: [(NonVoid Id, ByteOff)]
header = if isLFThunk lf_info then ThunkHeader else StdHeader
(tot_wds, ptr_wds, fv_details)
= mkVirtHeapOffsets profile header (addIdReps reduced_fvs)
closure_info = mkClosureInfo profile False -- Not static
bndr lf_info tot_wds ptr_wds
- descr
+ mod_name
-- BUILD ITS INFO TABLE AND CODE
; forkClosureBody $
@@ -478,10 +472,9 @@ cgRhsStdThunk bndr lf_info payload
= mkVirtHeapOffsets profile header
(addArgReps (nonVoidStgArgs payload))
- descr = closureDescription mod_name (idName bndr)
closure_info = mkClosureInfo profile False -- Not static
bndr lf_info tot_wds ptr_wds
- descr
+ mod_name
-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform
@@ -883,20 +876,3 @@ link_caf node = do
; return (CmmReg (CmmLocal bh)) }
-------------------------------------------------------------------------
--- Profiling
-------------------------------------------------------------------------
-
--- For "global" data constructors the description is simply occurrence
--- name of the data constructor itself. Otherwise it is determined by
--- @closureDescription@ from the let binding information.
-
-closureDescription
- :: Module -- Module
- -> Name -- Id of closure binding
- -> String
- -- Not called for StgRhsCon which have global info tables built in
- -- CgConTbls.hs with a description generated from the data constructor
-closureDescription mod_name name
- = showSDocOneLine defaultSDocContext
- (char '<' <> pprFullName mod_name name <> char '>')
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -78,6 +78,7 @@ import GHC.Cmm.Utils
import GHC.StgToCmm.Types
import GHC.StgToCmm.Sequel
+import GHC.Unit.Types (Module)
import GHC.Types.CostCentre
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
@@ -86,8 +87,6 @@ import GHC.Types.Id.Info
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Core.Type
-import GHC.Core.TyCo.Rep
-import GHC.Tc.Utils.TcType
import GHC.Core.TyCon
import GHC.Types.RepType
import GHC.Types.Basic
@@ -96,7 +95,6 @@ import GHC.Utils.Panic
import GHC.Data.Maybe (isNothing)
import Data.Coerce (coerce)
-import qualified Data.ByteString.Char8 as BS8
import GHC.StgToCmm.Config
import GHC.Stg.InferTags.TagSig (isTaggedSig)
@@ -701,9 +699,9 @@ mkClosureInfo :: Profile
-> Id
-> LambdaFormInfo
-> Int -> Int -- Total and pointer words
- -> String -- String descriptor
+ -> Module
-> ClosureInfo
-mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr
+mkClosureInfo profile is_static id lf_info tot_wds ptr_wds mod_name
= ClosureInfo { closureName = id
, closureLFInfo = lf_info
, closureInfoLabel = info_lbl -- These three fields are
@@ -711,7 +709,7 @@ mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr
, closureProf = prof } -- (we don't have an SRT yet)
where
sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)
- prof = mkProfilingInfo profile id val_descr
+ prof = mkProfilingInfo profile mod_name id
nonptr_wds = tot_wds - ptr_wds
info_lbl = mkClosureInfoTableLabel (profilePlatform profile) id lf_info
@@ -909,46 +907,24 @@ enterIdLabel platform id c
--------------------------------------
-- Profiling
--------------------------------------
-
+--
-- Profiling requires two pieces of information to be determined for
-- each closure's info table --- description and type.
-
--- The description is stored directly in the @CClosureInfoTable@ when the
+--
+-- This information can be constructed from the current module and an Id.
+-- We store the latter two in @ProfilingInfo@ and construct the information
+-- with @renderProfInfo@ in GHC.Cmm.
+--
+-- The description is stored directly in the @ClosureInfoTable@ when the
-- info table is built.
-
+--
-- The type is determined from the type information stored with the @Id@
-- in the closure info using @closureTypeDescr at .
-mkProfilingInfo :: Profile -> Id -> String -> ProfilingInfo
-mkProfilingInfo profile id val_descr
+mkProfilingInfo :: Profile -> Module -> Id -> ProfilingInfo
+mkProfilingInfo profile mod_name id
| not (profileIsProfiling profile) = NoProfilingInfo
- | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)
- where
- ty_descr_w8 = BS8.pack (getTyDescription (idType id))
-
-getTyDescription :: Type -> String
-getTyDescription ty
- = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
- case tau_ty of
- TyVarTy _ -> "*"
- AppTy fun _ -> getTyDescription fun
- TyConApp tycon _ -> getOccString tycon
- FunTy {} -> '-' : fun_result tau_ty
- ForAllTy _ ty -> getTyDescription ty
- LitTy n -> getTyLitDescription n
- CastTy ty _ -> getTyDescription ty
- CoercionTy co -> pprPanic "getTyDescription" (ppr co)
- }
- where
- fun_result (FunTy { ft_res = res }) = '>' : fun_result res
- fun_result other = getTyDescription other
-
-getTyLitDescription :: TyLit -> String
-getTyLitDescription l =
- case l of
- NumTyLit n -> show n
- StrTyLit n -> show n
- CharTyLit n -> show n
+ | otherwise = ClosureProfilingInfo mod_name id
--------------------------------------
-- CmmInfoTable-related things
@@ -970,10 +946,10 @@ mkDataConInfoTable profile data_con mn is_static ptr_wds nonptr_wds
-- of the info table of a data constructor.
prof | not (profileIsProfiling profile) = NoProfilingInfo
- | otherwise = ProfilingInfo ty_descr val_descr
+ | otherwise = DataProfilingInfo datacon_tycon_name datacon_name
- ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
- val_descr = BS8.pack $ occNameString $ getOccName data_con
+ datacon_tycon_name = getName $ dataConTyCon data_con
+ datacon_name = getName data_con
-- We need a black-hole closure info to pass to @allocDynClosure@ when we
-- want to allocate the black hole on entry to a CAF.
=====================================
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/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/0c6fa0b162989d2ff9c6486ef40d7ed7c3326663...3869ecbb1fc3ba6f136fe48c00ef304432162126
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c6fa0b162989d2ff9c6486ef40d7ed7c3326663...3869ecbb1fc3ba6f136fe48c00ef304432162126
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/dc2ca3e1/attachment-0001.html>
More information about the ghc-commits
mailing list