[Git][ghc/ghc][master] 3 commits: Specialise: Improve specialisation by refactoring interestingDict
by Marge Bot (＠marge-bot) 15 Jul '25
by Marge Bot (＠marge-bot) 15 Jul '25
15 Jul '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
f707bab4 by Andreas Klebinger at 2025-07-12T14:56:16+01:00
Specialise: Improve specialisation by refactoring interestingDict
This MR addresses #26051, which concerns missed type-class specialisation.
The main payload of the MR is to completely refactor the key function
`interestingDict` in GHC.Core.Opt.Specialise
The main change is that we now also look at the structure of the
dictionary we consider specializing on, rather than only the type.
See the big `Note [Interesting dictionary arguments]`
- - - - -
ca7a9d42 by Simon Peyton Jones at 2025-07-12T14:56:16+01:00
Treat tuple dictionaries uniformly; don't unbox them
See `Note [Do not unbox class dictionaries]` in DmdAnal.hs,
sep (DNB1).
This MR reverses the plan in #23398, which suggested a special case to
unbox tuple dictionaries in worker/wrapper. But:
- This was the cause of a pile of complexity in the specialiser (#26158)
- Even with that complexity, specialision was still bad, very bad
See https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297
And it's entirely unnecessary! Specialision works fine without
unboxing tuple dictionaries.
- - - - -
be7296c9 by Andreas Klebinger at 2025-07-12T14:56:16+01:00
Remove complex special case from the type-class specialiser
There was a pretty tricky special case in Specialise which is no
longer necessary.
* Historical Note [Floating dictionaries out of cases]
* #26158
* #19747 https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297
This MR removes it. Hooray.
- - - - -
18 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- testsuite/tests/dmdanal/should_compile/T23398.hs
- testsuite/tests/dmdanal/should_compile/T23398.stderr
- + testsuite/tests/perf/should_run/SpecTyFamRun.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.stdout
- + testsuite/tests/perf/should_run/SpecTyFam_Import.hs
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T26051.hs
- + testsuite/tests/simplCore/should_compile/T26051.stderr
- + testsuite/tests/simplCore/should_compile/T26051_Import.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -23,7 +23,7 @@ import GHC.Core.DataCon
import GHC.Core.Utils
import GHC.Core.TyCon
import GHC.Core.Type
-import GHC.Core.Predicate( isEqualityClass, isCTupleClass )
+import GHC.Core.Predicate( isEqualityClass {- , isCTupleClass -} )
import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
import GHC.Core.Coercion ( Coercion )
import GHC.Core.TyCo.FVs ( coVarsOfCos )
@@ -2194,7 +2194,7 @@ doNotUnbox :: Type -> Bool
doNotUnbox arg_ty
= case tyConAppTyCon_maybe arg_ty of
Just tc | Just cls <- tyConClass_maybe tc
- -> not (isEqualityClass cls || isCTupleClass cls)
+ -> not (isEqualityClass cls)
-- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]
_ -> False
@@ -2232,22 +2232,32 @@ TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing
a raft of higher-order functions isn't a huge win anyway -- you really want to
specialise the function.
-Wrinkle (DNB1): we /do/ want to unbox tuple dictionaries (#23398)
- f :: (% Eq a, Show a %) => blah
- with -fdicts-strict it is great to unbox to
- $wf :: Eq a => Show a => blah
- (where I have written out the currying explicitly). Now we can specialise
- $wf on the Eq or Show dictionary. Nothing is lost.
-
- And something is gained. It is possible that `f` will look like this:
- f = /\a. \d:(% Eq a, Show a %). ... f @a (% sel1 d, sel2 d %)...
- where there is a recurive call to `f`, or to another function that takes the
- same tuple dictionary, but where the tuple is built from the components of
- `d`. The Simplier does not fix this. But if we unpacked the dictionary
- we'd get
- $wf = /\a. \(d1:Eq a) (d2:Show a). let d = (% d1, d2 %)
- in ...f @a (% sel1 d, sel2 d %)
- and all the tuple building and taking apart will disappear.
+Wrinkle (DNB1): we /do not/ to unbox tuple dictionaries either. We used to
+ have a special case to unbox tuple dictionaries (#23398), but it ultimately
+ turned out to be a very bad idea (see !19747#note_626297). In summary:
+
+ - If w/w unboxes tuple dictionaries we get things like
+ case d of CTuple2 d1 d2 -> blah
+ rather than
+ let { d1 = sc_sel1 d; d2 = sc_sel2 d } in blah
+ The latter works much better with the specialiser: when `d` is instantiated
+ to some useful dictionary the `sc_sel1 d` selection can fire.
+
+ - The attempt to deal with unpacking dictionaries with `case` led to
+ significant extra complexity in the type-class specialiser (#26158) that is
+ rendered unnecessary if we only take do superclass selection with superclass
+ selectors, never with `case` expressions.
+
+ Even with that extra complexity, specialisation was /still/ sometimes worse,
+ and sometimes /tremendously/ worse (a factor of 70x); see #19747.
+
+ - Suppose f :: forall a. (% Eq a, Show a %) => blah
+ The specialiser is perfectly capable of specialising a call like
+ f @Int (% dEqInt, dShowInt %)
+ so the tuple doesn't get in the way.
+
+ - It's simpler and more uniform. There is nothing special about constraint
+ tuples; anyone can write class (C1 a, C2 a) => D a where {}
Wrinkle (DNB2): we /do/ want to unbox equality dictionaries,
for (~), (~~), and Coercible (#23398). Their payload is a single unboxed
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE MultiWayIf #-}
+
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -14,9 +16,9 @@ import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst )
-import GHC.Core.Multiplicity
-import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )
+import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe )
import GHC.Core.Predicate
+import GHC.Core.Class( classMethods )
import GHC.Core.Coercion( Coercion )
import GHC.Core.Opt.Monad
import qualified GHC.Core.Subst as Core
@@ -26,12 +28,12 @@ import GHC.Core.Make ( mkLitRubbish )
import GHC.Core.Unify ( tcMatchTy )
import GHC.Core.Rules
import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable
- , mkCast, exprType
+ , mkCast, exprType, exprIsHNF
, stripTicksTop, mkInScopeSetBndrs )
import GHC.Core.FVs
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Core.Opt.Arity( collectBindersPushingCo )
--- import GHC.Core.Ppr( pprIds )
+import GHC.Core.Ppr( pprIds )
import GHC.Builtin.Types ( unboxedUnitTy )
@@ -64,8 +66,12 @@ import GHC.Unit.Module.ModGuts
import GHC.Core.Unfold
import Data.List( partition )
-import Data.List.NonEmpty ( NonEmpty (..) )
+-- import Data.List.NonEmpty ( NonEmpty (..) )
import GHC.Core.Subst (substTickish)
+import GHC.Core.TyCon (tyConClass_maybe)
+import GHC.Core.DataCon (dataConTyCon)
+
+import Control.Monad
{-
************************************************************************
@@ -1277,67 +1283,10 @@ specCase :: SpecEnv
, OutId
, [OutAlt]
, UsageDetails)
-specCase env scrut' case_bndr [Alt con args rhs]
- | -- See Note [Floating dictionaries out of cases]
- interestingDict scrut' (idType case_bndr)
- , not (isDeadBinder case_bndr && null sc_args')
- = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
-
- ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
- scrut_bind = mkDB (NonRec case_bndr_flt scrut')
-
- sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss
- sc_rhss = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg')
- [Alt con args' (Var sc_arg')]
- | sc_arg' <- sc_args' ]
- cb_set = unitVarSet case_bndr_flt'
- sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs = cb_set }
- | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ]
-
- flt_binds = scrut_bind : sc_binds
-
- -- Extend the substitution for RHS to map the *original* binders
- -- to their floated versions.
- mb_sc_flts :: [Maybe DictId]
- mb_sc_flts = map (lookupVarEnv clone_env) args'
- clone_env = zipVarEnv sc_args' sc_args_flt'
-
- subst_prs = (case_bndr, Var case_bndr_flt)
- : [ (arg, Var sc_flt)
- | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
- subst' = se_subst env_rhs
- `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt')
- `Core.extendIdSubstList` subst_prs
- env_rhs' = env_rhs { se_subst = subst' }
-
- ; (rhs', rhs_uds) <- specExpr env_rhs' rhs
- ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
- all_uds = flt_binds `consDictBinds` free_uds
- alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs')
--- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $
- ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
- where
- (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)
- sc_args' = filter is_flt_sc_arg args'
-
- clone_me bndr = do { uniq <- getUniqueM
- ; return (mkUserLocalOrCoVar occ uniq wght ty loc) }
- where
- name = idName bndr
- wght = idMult bndr
- ty = idType bndr
- occ = nameOccName name
- loc = getSrcSpan name
-
- arg_set = mkVarSet args'
- is_flt_sc_arg var = isId var
- && not (isDeadBinder var)
- && isDictTy var_ty
- && tyCoVarsOfType var_ty `disjointVarSet` arg_set
- where
- var_ty = idType var
-
-
+-- We used to have a complex special case for
+-- case d of { CTuple2 d1 d2 -> blah }
+-- but we no longer do so.
+-- See Historical Note [Floating dictionaries out of cases]
specCase env scrut case_bndr alts
= do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
; return (scrut, case_bndr', alts', uds_alts) }
@@ -1346,14 +1295,11 @@ specCase env scrut case_bndr alts
spec_alt (Alt con args rhs)
= do { (rhs', uds) <- specExpr env_rhs rhs
; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
--- ; unless (isNilOL dumped_dbs) $
--- pprTrace "specAlt" (vcat
--- [text "case_bndr', args" <+> (ppr case_bndr' $$ ppr args)
--- ,text "dumped" <+> ppr dumped_dbs ]) return ()
; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) }
where
(env_rhs, args') = substBndrs env_alt args
+
{- Note [Fire rules in the specialiser]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (#21851)
@@ -1414,36 +1360,39 @@ Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant. That is,
if we run rules in the specialiser, does it matter if we make rules "win" over
inlining in the Simplifier? Yes, it does! See the discussion in #21851.
-Note [Floating dictionaries out of cases]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
+Historical Note [Floating dictionaries out of cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Function `specCase` used to give special treatment to a case-expression
+that scrutinised a dictionary, like this:
g = \d. case d of { MkD sc ... -> ...(f sc)... }
-Naively we can't float d2's binding out of the case expression,
-because 'sc' is bound by the case, and that in turn means we can't
-specialise f, which seems a pity.
-
-So we invert the case, by floating out a binding
-for 'sc_flt' thus:
- sc_flt = case d of { MkD sc ... -> sc }
-Now we can float the call instance for 'f'. Indeed this is just
-what'll happen if 'sc' was originally bound with a let binding,
-but case is more efficient, and necessary with equalities. So it's
-good to work with both.
-
-You might think that this won't make any difference, because the
-call instance will only get nuked by the \d. BUT if 'g' itself is
-specialised, then transitively we should be able to specialise f.
-
-In general, given
- case e of cb { MkD sc ... -> ...(f sc)... }
-we transform to
- let cb_flt = e
- sc_flt = case cb_flt of { MkD sc ... -> sc }
- in
- case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }
-
-The "_flt" things are the floated binds; we use the current substitution
-to substitute sc -> sc_flt in the RHS
+But actually
+
+* We never explicitly case-analyse a dictionary; rather the class-op
+ rules select superclasses from it. NB: in the past worker/wrapper
+ unboxed tuple dictionaries, but no longer; see (DNB1) in
+ Note [Do not unbox class dictionaries] in GHC.Core.Opt.DmdAnal.
+ Now it really is the case that only the class-op and superclass
+ selectors take dictionaries apart.
+
+* Calling `interestingDict` on every scrutinee is hardly sensible;
+ generally `interestingDict` is called only on Constraint-kinded things.
+
+* It was giving a Lint scope error in !14272
+
+So now there is no special case. This Note just records the change
+in case we ever want to reinstate it. The original note was
+added in
+
+ commit c107a00ccf1e641a2d008939cf477c71caa028d5
+ Author: Simon Peyton Jones <simonpj(a)microsoft.com>
+ Date: Thu Aug 12 13:11:33 2010 +0000
+
+ Improve the Specialiser, fixing Trac #4203
+
+The ticket to remove the code is #26158.
+
+End of Historical Note
+
************************************************************************
* *
@@ -1644,9 +1593,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- switch off specialisation for inline functions
= -- pprTrace "specCalls: some" (vcat
- -- [ text "function" <+> ppr fn
- -- , text "calls:" <+> ppr calls_for_me
- -- , text "subst" <+> ppr (se_subst env) ]) $
+ -- [ text "function" <+> ppr fn
+ -- , text "calls:" <+> ppr calls_for_me
+ -- , text "subst" <+> ppr (se_subst env) ]) $
foldlM spec_call ([], [], emptyUDs) calls_for_me
| otherwise -- No calls or RHS doesn't fit our preconceptions
@@ -1694,21 +1643,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
, rule_bndrs, rule_lhs_args
, spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
--- ; pprTrace "spec_call" (vcat
--- [ text "fun: " <+> ppr fn
--- , text "call info: " <+> ppr _ci
--- , text "useful: " <+> ppr useful
--- , text "rule_bndrs:" <+> ppr rule_bndrs
--- , text "lhs_args: " <+> ppr rule_lhs_args
--- , text "spec_bndrs1:" <+> ppr spec_bndrs1
--- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
--- , text "spec_args: " <+> ppr spec_args
--- , text "dx_binds: " <+> ppr dx_binds
--- , text "rhs_bndrs" <+> ppr rhs_bndrs
--- , text "rhs_body" <+> ppr rhs_body
--- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
--- , ppr dx_binds ]) $
--- return ()
+ ; when False $ pprTrace "spec_call" (vcat
+ [ text "fun: " <+> ppr fn
+ , text "call info: " <+> ppr _ci
+ , text "useful: " <+> ppr useful
+ , text "rule_bndrs:" <+> ppr rule_bndrs
+ , text "lhs_args: " <+> ppr rule_lhs_args
+ , text "spec_bndrs1:" <+> ppr spec_bndrs1
+ , text "leftover_bndrs:" <+> pprIds leftover_bndrs
+ , text "spec_args: " <+> ppr spec_args
+ , text "dx_binds: " <+> ppr dx_binds
+ , text "rhs_bndrs" <+> ppr rhs_bndrs
+ , text "rhs_body" <+> ppr rhs_body
+ , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
+ , ppr dx_binds ]) $
+ return ()
; let all_rules = rules_acc ++ existing_rules
-- all_rules: we look both in the rules_acc (generated by this invocation
@@ -3102,30 +3051,14 @@ mkCallUDs' env f args
-- For "invisibleFunArg", which are the type-class dictionaries,
-- we decide on a case by case basis if we want to specialise
-- on this argument; if so, SpecDict, if not UnspecArg
- mk_spec_arg arg (Anon pred af)
+ mk_spec_arg arg (Anon _pred af)
| isInvisibleFunArg af
- , interestingDict arg (scaledThing pred)
+ , interestingDict env arg
-- See Note [Interesting dictionary arguments]
= SpecDict arg
| otherwise = UnspecArg
-{-
-Note [Ticks on applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticks such as source location annotations can sometimes make their way
-onto applications (see e.g. #21697). So if we see something like
-
- App (Tick _ f) e
-
-we need to descend below the tick to find what the real function being
-applied is.
-
-The resulting RULE also has to be able to match this annotated use
-site, so we only look through ticks that RULE matching looks through
-(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
--}
-
wantCallsFor :: SpecEnv -> Id -> Bool
-- See Note [wantCallsFor]
wantCallsFor _env f
@@ -3145,8 +3078,60 @@ wantCallsFor _env f
WorkerLikeId {} -> True
RepPolyId {} -> True
-{- Note [wantCallsFor]
-~~~~~~~~~~~~~~~~~~~~~~
+interestingDict :: SpecEnv -> CoreExpr -> Bool
+-- This is a subtle and important function
+-- See Note [Interesting dictionary arguments]
+interestingDict env (Var v) -- See (ID3) and (ID5)
+ | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)
+ -- Might fail for loop breaker dicts but that seems fine.
+ = interestingDict env rhs
+
+interestingDict env arg -- Main Plan: use exprIsConApp_maybe
+ | Cast inner_arg _ <- arg -- See (ID5)
+ = if | isConstraintKind $ typeKind $ exprType inner_arg
+ -- If coercions were always homo-kinded, we'd know
+ -- that this would be the only case
+ -> interestingDict env inner_arg
+
+ -- Check for an implicit parameter at the top
+ | Just (cls,_) <- getClassPredTys_maybe arg_ty
+ , isIPClass cls -- See (ID5)
+ -> False
+
+ -- Otherwise we are unwrapping a unary type class
+ | otherwise
+ -> exprIsHNF arg -- See (ID7)
+
+ | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg
+ , Just cls <- tyConClass_maybe (dataConTyCon data_con)
+ , definitely_not_ip_like -- See (ID4)
+ = if null (classMethods cls) -- See (ID6)
+ then any (interestingDict env) args
+ else True
+
+ | otherwise
+ = not (exprIsTrivial arg) && definitely_not_ip_like -- See (ID8)
+ where
+ arg_ty = exprType arg
+ definitely_not_ip_like = not (couldBeIPLike arg_ty)
+ in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding
+
+{- Note [Ticks on applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticks such as source location annotations can sometimes make their way
+onto applications (see e.g. #21697). So if we see something like
+
+ App (Tick _ f) e
+
+we need to descend below the tick to find what the real function being
+applied is.
+
+The resulting RULE also has to be able to match this annotated use
+site, so we only look through ticks that RULE matching looks through
+(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
+
+Note [wantCallsFor]
+~~~~~~~~~~~~~~~~~~~
`wantCallsFor env f` says whether the Specialiser should collect calls for
function `f`; other thing being equal, the fewer calls we collect the better. It
is False for things we can't specialise:
@@ -3172,44 +3157,99 @@ collect usage info for imported overloaded functions.
Note [Interesting dictionary arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In `mkCallUDs` we only use `SpecDict` for dictionaries of which
-`interestingDict` holds. Otherwise we use `UnspecArg`. Two reasons:
-
-* Consider this
- \a.\d:Eq a. let f = ... in ...(f d)...
- There really is not much point in specialising f wrt the dictionary d,
- because the code for the specialised f is not improved at all, because
- d is lambda-bound. We simply get junk specialisations.
-
-* Consider this (#25703):
- f :: (Eq a, Show b) => a -> b -> INt
- goo :: forall x. (Eq x) => x -> blah
- goo @x (d:Eq x) (arg:x) = ...(f @x @Int d $fShowInt)...
- If we built a `ci_key` with a (SpecDict d) for `d`, we would end up
- discarding the call at the `\d`. But if we use `UnspecArg` for that
- uninteresting `d`, we'll get a `ci_key` of
- f @x @Int UnspecArg (SpecDict $fShowInt)
- and /that/ can float out to f's definition and specialise nicely.
- Hooray. (NB: the call can float only if `-fpolymorphic-specialisation`
- is on; otherwise it'll be trapped by the `\@x -> ...`.)(
-
-What is "interesting"? (See `interestingDict`.) Just that it has *some*
-structure. But what about variables? We look in the variable's /unfolding/.
-And that means that we must be careful to ensure that dictionaries /have/
-unfoldings,
-
-* cloneBndrSM discards non-Stable unfoldings
-* specBind updates the unfolding after specialisation
- See Note [Update unfolding after specialisation]
-* bindAuxiliaryDict adds an unfolding for an aux dict
- see Note [Specialisation modulo dictionary selectors]
-* specCase adds unfoldings for the new bindings it creates
-
-We accidentally lost accurate tracking of local variables for a long
-time, because cloned variables didn't have unfoldings. But makes a
-massive difference in a few cases, eg #5113. For nofib as a
-whole it's only a small win: 2.2% improvement in allocation for ansi,
-1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.
+Consider this
+ \a.\d:Eq a. let f = ... in ...(f d)...
+There really is not much point in specialising f wrt the dictionary d,
+because the code for the specialised f is not improved at all, because
+d is lambda-bound. We simply get junk specialisations.
+
+What is "interesting"? Our Main Plan is to use `exprIsConApp_maybe` to see
+if the argument is a dictionary constructor applied to some arguments, in which
+case we can clearly specialise. But there are wrinkles:
+
+(ID1) Note that we look at the argument /term/, not its /type/. Suppose the
+ argument is
+ (% d1, d2 %) |> co
+ where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.
+ Then its type (F Int a) looks very un-informative, but the term is super
+ helpful. See #19747 (where missing this point caused a 70x slow down)
+ and #7785.
+
+(ID2) Note that the Main Plan works fine for an argument that is a DFun call,
+ e.g. $fOrdList $dOrdInt
+ because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good!
+
+(ID3) For variables, we look in the variable's /unfolding/. And that means
+ that we must be careful to ensure that dictionaries /have/ unfoldings:
+ * cloneBndrSM discards non-Stable unfoldings
+ * specBind updates the unfolding after specialisation
+ See Note [Update unfolding after specialisation]
+ * bindAuxiliaryDict adds an unfolding for an aux dict
+ see Note [Specialisation modulo dictionary selectors]
+ * specCase adds unfoldings for the new bindings it creates
+
+ We accidentally lost accurate tracking of local variables for a long
+ time, because cloned variables didn't have unfoldings. But makes a
+ massive difference in a few cases, eg #5113. For nofib as a
+ whole it's only a small win: 2.2% improvement in allocation for ansi,
+ 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.
+
+(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains
+ an implicit parameter, because implicit parameters are emphatically not singleton
+ types. See #25999:
+ useImplicit :: (?i :: Int) => Int
+ useImplicit = ?i + 1
+
+ foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)
+ Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.
+ We must not specialise on implicit parameters! Hence the call to `couldBeIPLike`
+ in `definitely_not_ip_like`.
+
+(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal
+ with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type
+ constructor at the top of both sides. But see the example in (ID1), where that
+ is not true. For the same reason, we can't rely on `exprIsConApp_maybe` to look
+ through unfoldings (because there might be a cast inside), hence dealing with
+ expandable unfoldings in `interestingDict` directly.
+
+ For the same reasons as in (ID4), we must take care to not allow an implicit
+ parameter to sneak through, so we must not unwrap the newtype cast for the
+ unary IP class; hence the `isIPClass` call. (We don't need to call
+ `couldBeIPLike`, as implicit parameters hidden behind a type family are
+ detected by the recursive call to `interestingDict` on the argument inside the
+ cast.)
+
+(ID6) The Main Plan says that it's worth specialising if the argument is an application
+ of a dictionary contructor. But what if the dictionary has no methods? Then we
+ gain nothing by specialising, unless the /superclasses/ are interesting. A case
+ in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class
+ with N superclasses and no methods.
+
+(ID7) A unary (single-method) class is currently represented by (meth |> co). We
+ will unwrap the cast (see (ID5)) and then want to reply "yes" if the method
+ has any struture. We rather arbitrarily use `exprIsHNF` for this. (We plan a
+ new story for unary classes, see #23109, and this special case will become
+ irrelevant.)
+
+(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a
+ non-trivial argument as interesting. In T19695 we have this:
+ askParams :: Monad m => blah
+ mhelper :: MonadIO m => blah
+ mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....
+ where `$p1` is the superclass selector for `MonadIO`. Now, if `mhelper` is
+ specialised at `Handler` we'll get this call in the specialised `$smhelper`:
+ askParams @Handler ($p1 $fMonadIOHandler)
+ and we /definitely/ want to specialise that, even though the argument isn't
+ visibly a dictionary application. In fact the specialiser fires the superclass
+ selector rule (see Note [Fire rules in the specialiser]), so we get
+ askParams @Handler ($cp1MonadIO $fMonadIOIO)
+ but it /still/ doesn't look like a dictionary application.
+
+ Conclusion: we optimistically assume that any non-trivial argument is worth
+ specialising on.
+
+ So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look
+ under type-family casts (ID1) and constraint tuples (ID6).
Note [Update unfolding after specialisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3237,6 +3277,7 @@ Consider (#21848)
Now `f` turns into:
f @a @b (dd :: D a) (ds :: Show b) a b
+
= let dc :: D a = %p1 dd -- Superclass selection
in meth @a dc ....
meth @a dc ....
@@ -3252,27 +3293,6 @@ in the NonRec case of specBind. (This is too exotic to trouble with
the Rec case.)
-}
-interestingDict :: CoreExpr -> Type -> Bool
--- A dictionary argument is interesting if it has *some* structure,
--- see Note [Interesting dictionary arguments]
--- NB: "dictionary" arguments include constraints of all sorts,
--- including equality constraints; hence the Coercion case
--- To make this work, we need to ensure that dictionaries have
--- unfoldings in them.
-interestingDict arg arg_ty
- | not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value]
- | otherwise = go arg
- where
- go (Var v) = hasSomeUnfolding (idUnfolding v)
- || isDataConWorkId v
- go (Type _) = False
- go (Coercion _) = False
- go (App fn (Type _)) = go fn
- go (App fn (Coercion _)) = go fn
- go (Tick _ a) = go a
- go (Cast e _) = go e
- go _ = True
-
thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
(MkUD {ud_binds = db2, ud_calls = calls2})
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.Core.Predicate (
classMethodTy, classMethodInstTy,
-- Implicit parameters
- isIPLikePred, mentionsIP, isIPTyCon, isIPClass,
+ couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass,
isCallStackTy, isCallStackPred, isCallStackPredTy,
isExceptionContextPred, isExceptionContextTy,
isIPPred_maybe,
@@ -126,9 +126,12 @@ isDictTy ty = isClassPred pred
where
(_, pred) = splitInvisPiTys ty
+-- | Is the type *guaranteed* to determine the value?
+--
+-- Might say No even if the type does determine the value. (See the Note)
typeDeterminesValue :: Type -> Bool
-- See Note [Type determines value]
-typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)
+typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty)
getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
getClassPredTys ty = case getClassPredTys_maybe ty of
@@ -171,6 +174,10 @@ So we treat implicit params just like ordinary arguments for the
purposes of specialisation. Note that we still want to specialise
functions with implicit params if they have *other* dicts which are
class params; see #17930.
+
+It's also not always possible to infer that a type determines the value
+if type families are in play. See #19747 for one such example.
+
-}
-- --------------------- Equality predicates ---------------------------------
@@ -421,44 +428,44 @@ isCallStackTy ty
| otherwise
= False
--- --------------------- isIPLike and mentionsIP --------------------------
+-- --------------------- couldBeIPLike and mightMentionIP --------------------------
-- See Note [Local implicit parameters]
-isIPLikePred :: Type -> Bool
+couldBeIPLike :: Type -> Bool
-- Is `pred`, or any of its superclasses, an implicit parameter?
-- See Note [Local implicit parameters]
-isIPLikePred pred =
- mentions_ip_pred initIPRecTc (const True) (const True) pred
-
-mentionsIP :: (Type -> Bool) -- ^ predicate on the string
- -> (Type -> Bool) -- ^ predicate on the type
- -> Class
- -> [Type] -> Bool
--- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:
+couldBeIPLike pred
+ = might_mention_ip1 initIPRecTc (const True) (const True) pred
+
+mightMentionIP :: (Type -> Bool) -- ^ predicate on the string
+ -> (Type -> Bool) -- ^ predicate on the type
+ -> Class
+ -> [Type] -> Bool
+-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if:
--
-- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@
-- are both @True@,
-- - or any superclass of @cls tys@ has this property.
--
-- See Note [Local implicit parameters]
-mentionsIP = mentions_ip initIPRecTc
+mightMentionIP = might_mention_ip initIPRecTc
-mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
-mentions_ip rec_clss str_cond ty_cond cls tys
+might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
+might_mention_ip rec_clss str_cond ty_cond cls tys
| Just (str_ty, ty) <- isIPPred_maybe cls tys
= str_cond str_ty && ty_cond ty
| otherwise
- = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
+ = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
| sc_sel_id <- classSCSelIds cls ]
-mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
-mentions_ip_pred rec_clss str_cond ty_cond ty
+might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
+might_mention_ip1 rec_clss str_cond ty_cond ty
| Just (cls, tys) <- getClassPredTys_maybe ty
, let tc = classTyCon cls
, Just rec_clss' <- if isTupleTyCon tc then Just rec_clss
else checkRecTc rec_clss tc
- = mentions_ip rec_clss' str_cond ty_cond cls tys
+ = might_mention_ip rec_clss' str_cond ty_cond cls tys
| otherwise
= False -- Includes things like (D []) where D is
-- a Constraint-ranged family; #7785
@@ -471,7 +478,7 @@ initIPRecTc = setRecTcMaxBound 1 initRecTc
See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in
GHC.Tc.Solver.Dict.
-The function isIPLikePred tells if this predicate, or any of its
+The function couldBeIPLike tells if this predicate, or any of its
superclasses, is an implicit parameter.
Why are implicit parameters special? Unlike normal classes, we can
@@ -479,7 +486,7 @@ have local instances for implicit parameters, in the form of
let ?x = True in ...
So in various places we must be careful not to assume that any value
of the right type will do; we must carefully look for the innermost binding.
-So isIPLikePred checks whether this is an implicit parameter, or has
+So couldBeIPLike checks whether this is an implicit parameter, or has
a superclass that is an implicit parameter.
Several wrinkles
@@ -520,16 +527,16 @@ Small worries (Sept 20):
think nothing does.
* I'm a little concerned about type variables; such a variable might
be instantiated to an implicit parameter. I don't think this
- matters in the cases for which isIPLikePred is used, and it's pretty
+ matters in the cases for which couldBeIPLike is used, and it's pretty
obscure anyway.
* The superclass hunt stops when it encounters the same class again,
but in principle we could have the same class, differently instantiated,
and the second time it could have an implicit parameter
I'm going to treat these as problems for another day. They are all exotic.
-Note [Using typesAreApart when calling mentionsIP]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We call 'mentionsIP' in two situations:
+Note [Using typesAreApart when calling mightMentionIP]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We call 'mightMentionIP' in two situations:
(1) to check that a predicate does not contain any implicit parameters
IP str ty, for a fixed literal str and any type ty,
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1914,7 +1914,7 @@ growThetaTyVars theta tcvs
| otherwise = transCloVarSet mk_next seed_tcvs
where
seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
- (ips, non_ips) = partition isIPLikePred theta
+ (ips, non_ips) = partition couldBeIPLike theta
-- See Note [Inheriting implicit parameters]
mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -749,7 +749,7 @@ shortCutSolver dflags ev_w ev_i
-- programs should typecheck regardless of whether we take this step or
-- not. See Note [Shortcut solving]
- , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
+ , not (couldBeIPLike (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
, not (xopt LangExt.IncoherentInstances dflags)
-- If IncoherentInstances is on then we cannot rely on coherence of proofs
=====================================
compiler/GHC/Tc/Solver/InertSet.hs
=====================================
@@ -2040,10 +2040,10 @@ solveOneFromTheOther ct_i ct_w
is_wsc_orig_w = isWantedSuperclassOrigin orig_w
different_level_strategy -- Both Given
- | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert
- | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
+ | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert
+ | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
-- See Note [Replacement vs keeping] part (1)
- -- For the isIPLikePred case see Note [Shadowing of implicit parameters]
+ -- For the couldBeIPLike case see Note [Shadowing of implicit parameters]
-- in GHC.Tc.Solver.Dict
same_level_strategy -- Both Given
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -401,8 +401,8 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
-- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
does_not_mention_ip_for :: Type -> DictCt -> Bool
does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys
- -- See Note [Using typesAreApart when calling mentionsIP]
+ = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
+ -- See Note [Using typesAreApart when calling mightMentionIP]
-- in GHC.Core.Predicate
updInertIrreds :: IrredCt -> TcS ()
@@ -534,7 +534,7 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })
= do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName
; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName
; let contains_callstack_or_exceptionCtx =
- mentionsIP
+ mightMentionIP
(const True)
-- NB: the name of the call-stack IP is irrelevant
-- e.g (?foo :: CallStack) counts!
@@ -552,9 +552,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })
-- Return a predicate that decides whether a type is CallStack
-- or ExceptionContext, accounting for e.g. type family reduction, as
- -- per Note [Using typesAreApart when calling mentionsIP].
+ -- per Note [Using typesAreApart when calling mightMentionIP].
--
- -- See Note [Using isCallStackTy in mentionsIP].
+ -- See Note [Using isCallStackTy in mightMentionIP].
is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)
is_tyConTy is_eq tc_name
= do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name
@@ -582,14 +582,14 @@ in a different context!
See also Note [Shadowing of implicit parameters], which deals with a similar
problem with Given implicit parameter constraints.
-Note [Using isCallStackTy in mentionsIP]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Using isCallStackTy in mightMentionIP]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To implement Note [Don't add HasCallStack constraints to the solved set],
we need to check whether a constraint contains a HasCallStack or HasExceptionContext
constraint. We do this using the 'mentionsIP' function, but as per
-Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:
+Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do:
- mentionsIP
+ mightMentionIP
(const True) -- (ignore the implicit parameter string)
(isCallStackTy <||> isExceptionContextTy)
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -155,7 +155,7 @@ module GHC.Tc.Utils.TcType (
mkTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
- isClassPred, isEqPred, isIPLikePred, isEqClassPred,
+ isClassPred, isEqPred, couldBeIPLike, isEqClassPred,
isEqualityClass, mkClassPred,
tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
isRuntimeRepVar, isFixedRuntimeRepKind,
@@ -1819,7 +1819,7 @@ pickCapturedPreds
pickCapturedPreds qtvs theta
= filter captured theta
where
- captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
+ captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
-- Superclasses
=====================================
testsuite/tests/dmdanal/should_compile/T23398.hs
=====================================
@@ -6,10 +6,11 @@ type PairDict a = (Eq a, Show a)
foo :: PairDict a => a -> a -> String
foo x y | x==y = show x
| otherwise = show y
-
--- In worker/wrapper we'd like to unbox the pair
--- but not (Eq a) and (Show a)
+-- In worker/wrapper we don't want to unbox PairDict
+-- See (DNB1) Note [Do not unbox class dictionaries] in GHC.Core.Opt.DmdAnal
bar :: (a ~ b, Show a) => Int -> a -> (b, String)
bar 0 x = (x, show x)
bar n x = bar (n-1) x
+-- ...but we do want to unbox the (a~b)
+-- see (DNB2) in the same Note
=====================================
testsuite/tests/dmdanal/should_compile/T23398.stderr
=====================================
@@ -1,42 +1,35 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 76, types: 117, coercions: 4, joins: 0/0}
+ = {terms: 65, types: 107, coercions: 4, joins: 0/0}
--- RHS size: {terms: 18, types: 11, coercions: 0, joins: 0/0}
-T23398.$wfoo [InlPrag=[2]]
- :: forall a. (Eq a, Show a) => a -> a -> String
-[GblId[StrictWorker([!, !])],
- Arity=4,
- Str=<SP(1C(1,C(1,L)),A)><SP(A,1C(1,L),A)><L><L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True,
- Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [30 60 0 0] 120 0}]
-T23398.$wfoo
- = \ (@a) (ww :: Eq a) (ww1 :: Show a) (eta :: a) (eta1 :: a) ->
- case == @a ww eta eta1 of {
- False -> show @a ww1 eta1;
- True -> show @a ww1 eta
- }
-
--- RHS size: {terms: 12, types: 12, coercions: 0, joins: 0/0}
-foo [InlPrag=[2]] :: forall a. PairDict a => a -> a -> String
+-- RHS size: {terms: 20, types: 21, coercions: 0, joins: 0/0}
+foo :: forall a. PairDict a => a -> a -> String
[GblId,
Arity=3,
- Str=<S!P(SP(SC(S,C(1,L)),A),SP(A,SC(S,L),A))><L><L>,
- Unf=Unf{Src=StableSystem, TopLvl=True,
+ Str=<SP(SP(1C(1,C(1,L)),A),SP(A,1C(1,L),A))><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
- Tmpl= \ (@a)
- ($dCTuple2 [Occ=Once1!] :: PairDict a)
- (eta [Occ=Once1] :: a)
- (eta1 [Occ=Once1] :: a) ->
- case $dCTuple2 of { (ww [Occ=Once1], ww1 [Occ=Once1]) ->
- T23398.$wfoo @a ww ww1 eta eta1
- }}]
+ Guidance=IF_ARGS [90 0 0] 180 0}]
foo
= \ (@a) ($dCTuple2 :: PairDict a) (eta :: a) (eta1 :: a) ->
- case $dCTuple2 of { (ww, ww1) -> T23398.$wfoo @a ww ww1 eta eta1 }
+ case ==
+ @a
+ (GHC.Internal.Classes.$p0CTuple2 @(Eq a) @(Show a) $dCTuple2)
+ eta
+ eta1
+ of {
+ False ->
+ show
+ @a
+ (GHC.Internal.Classes.$p1CTuple2 @(Eq a) @(Show a) $dCTuple2)
+ eta1;
+ True ->
+ show
+ @a
+ (GHC.Internal.Classes.$p1CTuple2 @(Eq a) @(Show a) $dCTuple2)
+ eta
+ }
Rec {
-- RHS size: {terms: 21, types: 19, coercions: 3, joins: 0/0}
=====================================
testsuite/tests/perf/should_run/SpecTyFamRun.hs
=====================================
@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -fspecialise-aggressively #-}
+{-# OPTIONS_GHC -fno-spec-constr #-}
+module Main(main) where
+
+import SpecTyFam_Import (specMe, MaybeShowNum)
+import GHC.Exts
+
+-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
+
+{-# NOINLINE foo #-}
+foo :: Int -> (String,Int)
+-- We want specMe to be specialized, but not inlined
+foo x = specMe True x
+
+main = print $ sum $ map (snd . foo) [1..1000 :: Int]
=====================================
testsuite/tests/perf/should_run/SpecTyFamRun.stdout
=====================================
@@ -0,0 +1 @@
+500500
=====================================
testsuite/tests/perf/should_run/SpecTyFam_Import.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+
+module SpecTyFam_Import (specMe, MaybeShowNum) where
+
+import Data.Kind
+
+type family MaybeShowNum a n :: Constraint where
+ MaybeShowNum a n = (Show a, Num n)
+
+{-# INLINABLE specMe #-}
+specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
+specMe s !n = (show s, n+1 `div` 2)
=====================================
testsuite/tests/perf/should_run/all.T
=====================================
@@ -423,3 +423,12 @@ test('ByteCodeAsm',
],
compile_and_run,
['-package ghc'])
+
+# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats
+# See also #19747
+test('SpecTyFamRun', [ grep_errmsg(r'foo')
+ , extra_files(['SpecTyFam_Import.hs'])
+ , only_ways(['optasm'])
+ , collect_stats('bytes allocated', 5)],
+ multimod_compile_and_run,
+ ['SpecTyFamRun', '-O2'])
=====================================
testsuite/tests/simplCore/should_compile/T26051.hs
=====================================
@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -fspecialise-aggressively #-}
+{-# OPTIONS_GHC -fno-spec-constr #-}
+
+module T26051(main, foo) where
+
+import T26051_Import (specMe, MaybeShowNum)
+import GHC.Exts
+
+-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
+
+{-# OPAQUE foo #-}
+foo :: Int -> (String,Int)
+foo x = specMe True x
+
+main = print $ sum $ map (snd . foo) [1..1000 :: Int]
=====================================
testsuite/tests/simplCore/should_compile/T26051.stderr
=====================================
@@ -0,0 +1,78 @@
+[1 of 2] Compiling T26051_Import ( T26051_Import.hs, T26051_Import.o )
+
+==================== Specialise ====================
+Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1}
+
+-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1}
+specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n)
+[LclIdX,
+ Arity=4,
+ Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10
+ Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) ->
+ let {
+ $dNum :: Num n
+ [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
+ case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}]
+specMe
+ = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) ->
+ let {
+ $dNum :: Num n
+ [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
+ case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (T26051_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }
+
+
+
+[2 of 2] Compiling T26051 ( T26051.hs, T26051.o )
+
+==================== Specialise ====================
+Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1}
+
+Rec {
+-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0}
+$dCTuple2 :: (Show Bool, Num Int)
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt)
+
+-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1}
+$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #)
+[LclId, Arity=2]
+$s$wspecMe
+ = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) ->
+ let {
+ $dNum :: Num Int
+ [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
+ $dNum = GHC.Internal.Num.$fNumInt } in
+ case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) }
+
+-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0}
+$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int)
+[LclId,
+ Arity=2,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case T26051_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}]
+$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case T26051_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }
+end Rec }
+
+-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0}
+foo [InlPrag=OPAQUE] :: Int -> (String, Int)
+[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}]
+foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x
+
+-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0}
+main :: State# RealWorld -> (# State# RealWorld, () #)
+[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}]
+main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.StdHandles.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta
+
+-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0}
+main :: IO ()
+[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
+main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ())
+
+
+------ Local rules for imported ids --------
+"SPEC/T26051 $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). T26051_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe
+"SPEC/T26051 specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe
+
+
=====================================
testsuite/tests/simplCore/should_compile/T26051_Import.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ImplicitParams #-}
+
+module T26051_Import (specMe, MaybeShowNum) where
+
+import Data.Kind
+
+type family MaybeShowNum a n :: Constraint where
+ MaybeShowNum a n = (Show a, Num n)
+
+{-# INLINABLE specMe #-}
+specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
+specMe s !n = (show s, n+1 `div` 2)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -548,3 +548,9 @@ test('T25965', normal, compile, ['-O'])
test('T25703', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings'])
test('T25703a', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings'])
+# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats
+test('T26051', [ grep_errmsg(r'\$wspecMe')
+ , extra_files(['T26051_Import.hs'])
+ , only_ways(['optasm'])],
+ multimod_compile,
+ ['T26051', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b4db9bacf4a54552179154d067efc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b4db9bacf4a54552179154d067efc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
hi
1
0
[Git][ghc/ghc][wip/warning-for-last-and-init] Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
by Bodigrim (＠Bodigrim) 14 Jul '25
by Bodigrim (＠Bodigrim) 14 Jul '25
14 Jul '25
Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC
Commits:
dfabdcc0 by Mike Pilgrem at 2025-07-14T23:25:25+01:00
Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`).
In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository).
- - - - -
24 changed files:
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Prelude/Basic.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/src/Settings/Warnings.hs
- libraries/Cabal
- libraries/filepath
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- testsuite/tests/driver/j-space/jspace.hs
- testsuite/tests/rts/KeepCafsBase.hs
- utils/check-exact/Utils.hs
- utils/ghc-pkg/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/hpc
- utils/hsc2hs
Changes:
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -112,8 +112,7 @@ import GHC.Utils.Misc
import Data.ByteString ( ByteString )
import Data.Function ( on )
-import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
-import qualified Data.List as Partial ( init, last )
+import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc )
import Data.Ord ( comparing )
import Control.Monad ( guard )
import qualified Data.Set as Set
@@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args
PrimOpId op _
| primOpIsDiv op
- , Lit divisor <- Partial.last args
+ , Just (initArgs, Lit divisor) <- unsnoc args
-- there can be 2 args (most div primops) or 3 args
-- (WordQuotRem2Op), hence the use of last/init
- -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args)
+ -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs
-- Special case for dividing operations that fail
-- In general they are NOT ok-for-speculation
-- (which primop_ok will catch), but they ARE OK
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -183,7 +183,7 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)
processSCCs [] = return ()
processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs
- processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)
+ processSCCs (NECyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)
cycle_err uids =
@@ -195,8 +195,8 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)
(map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)
++ [text "-" <+> ppr final]
where
- start = init uids
- final = last uids
+ start = NE.init uids
+ final = NE.last uids
-- | Check that we don't have multiple units with the same UnitId.
checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()
=====================================
compiler/GHC/Prelude/Basic.hs
=====================================
@@ -2,8 +2,8 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude]
--- See Note [Proxies for head and tail]
-{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-}
+-- See Note [Proxies for partial list functions]
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- | Custom minimal GHC "Prelude"
--
@@ -24,7 +24,7 @@ module GHC.Prelude.Basic
, bit
, shiftL, shiftR
, setBit, clearBit
- , head, tail, unzip
+ , head, tail, init, last, unzip
, strictGenericLength
) where
@@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this:
-}
import qualified Prelude
-import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip)
+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip)
import Control.Applicative (Applicative(..))
import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum))
import Data.Foldable1 as X hiding (head, last)
@@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i
clearBit :: (Num a, Bits.Bits a) => a -> Int -> a
clearBit = \ x i -> x Bits..&. Bits.complement (bit i)
-{- Note [Proxies for head and tail]
+{- Note [Proxies for partial list functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-},
+Prelude.head, Prelude.tail, Prelude.init and Prelude.last
+have recently acquired {-# WARNING in "x-partial" #-},
but the GHC codebase uses them fairly extensively and insists on building warning-free.
Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which
employs them, we define warning-less proxies and export them from GHC.Prelude.
-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
head :: HasCallStack => [a] -> a
head = Prelude.head
{-# INLINE head #-}
--- See Note [Proxies for head and tail]
+-- See Note [Proxies for partial list functions]
tail :: HasCallStack => [a] -> [a]
tail = Prelude.tail
{-# INLINE tail #-}
+-- See Note [Proxies for partial list functions]
+init :: HasCallStack => [a] -> [a]
+init = Prelude.init
+{-# INLINE init #-}
+
+-- See Note [Proxies for partial list functions]
+last :: HasCallStack => [a] -> a
+last = Prelude.last
+{-# INLINE last #-}
+
{- |
The 'genericLength' function defined in base can't be specialised due to the
NOINLINE pragma.
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -133,7 +133,7 @@ import Data.Char
import Data.Function
import qualified Data.Foldable as Foldable
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( find, intercalate, intersperse,
+import Data.List ( find, intercalate, intersperse, unsnoc,
isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
@@ -2399,9 +2399,9 @@ setContextAfterLoad keep_ctxt (Just graph) = do
[] ->
let graph' = flattenSCCs $ filterToposortToModules $
GHC.topSortModuleGraph True (GHC.mkModuleGraph loaded_graph) Nothing
- in case graph' of
- [] -> setContextKeepingPackageModules keep_ctxt []
- xs -> load_this (last xs)
+ in case unsnoc graph' of
+ Nothing -> setContextKeepingPackageModules keep_ctxt []
+ Just (_, lst) -> load_this lst
(m:_) ->
load_this m
where
=====================================
ghc/Main.hs
=====================================
@@ -88,7 +88,7 @@ import System.Exit
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (throwE, runExceptT)
-import Data.List ( isPrefixOf, partition, intercalate )
+import Data.List ( isPrefixOf, partition, intercalate, unsnoc )
import Prelude
import qualified Data.List.NonEmpty as NE
@@ -115,8 +115,7 @@ main = do
argv0 <- getArgs
let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
- mbMinusB | null minusB_args = Nothing
- | otherwise = Just (drop 2 (last minusB_args))
+ mbMinusB = drop 2 . snd <$> unsnoc minusB_args
let argv2 = map (mkGeneralLocated "on the commandline") argv1
=====================================
hadrian/src/Settings/Warnings.hs
=====================================
@@ -68,11 +68,16 @@ ghcWarningsArgs = do
, package rts ? pure [ "-Wcpp-undef" ]
, package text ? pure [ "-Wno-deprecations"
, "-Wno-deriving-typeable"
- , "-Wno-unused-imports" ]
+ , "-Wno-unused-imports"
+ , "-Wno-x-partial" -- Awaiting version bumps for GHC 9.14 to land
+ ]
, package terminfo ? pure [ "-Wno-unused-imports", "-Wno-deriving-typeable" ]
, package stm ? pure [ "-Wno-deriving-typeable" ]
, package osString ? pure [ "-Wno-deriving-typeable", "-Wno-unused-imports" ]
- , package parsec ? pure [ "-Wno-deriving-typeable" ]
+ , package parsec ? pure [ "-Wno-deriving-typeable"
+ , "-Wno-x-partial"
+ -- https://github.com/haskell/parsec/issues/194
+ ]
, package cabal ? pure [ "-Wno-deriving-typeable", "-Wno-incomplete-record-selectors" ]
-- The -Wno-incomplete-record-selectors is due to
@@ -80,7 +85,9 @@ ghcWarningsArgs = do
-- If that ticket is fixed, bwe can remove the flag again
, package cabalSyntax ? pure [ "-Wno-deriving-typeable" ]
- , package time ? pure [ "-Wno-deriving-typeable" ]
+ , package time ? pure [ "-Wno-deriving-typeable"
+ , "-Wno-x-partial" -- Awaiting time-1.15 release
+ ]
, package transformers ? pure [ "-Wno-unused-matches"
, "-Wno-unused-imports"
, "-Wno-redundant-constraints"
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8
+Subproject commit 9a343d137bcc5ae97a8d6e7a670dd4fb67ea7294
=====================================
libraries/filepath
=====================================
@@ -1 +1 @@
-Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
+Subproject commit 62e71a8f512a0f2a477d8004751ccf2420b8ac28
=====================================
libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
=====================================
@@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib
import GHC.Boot.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr )
-import Data.List ( intersperse )
+import Data.List ( intersperse, unsnoc )
import GHC.Show ( showMultiLineString )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
@@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $
pprStms [s] = ppr s
pprStms ss = braces (semiSep ss)
-pprExp _ (CompE []) = text "<<Empty CompExp>>"
-- This will probably break with fixity declarations - would need a ';'
-pprExp _ (CompE ss) =
+pprExp _ (CompE ss) = case unsnoc ss of
+ Nothing -> text "<<Empty CompExp>>"
+ Just (ss', s) ->
if null ss'
-- If there are no statements in a list comprehension besides the last
-- one, we simply treat it like a normal list.
@@ -225,8 +226,6 @@ pprExp _ (CompE ss) =
<+> bar
<+> commaSep ss'
<> text "]"
- where s = last ss
- ss' = init ss
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets (commaSep es)
pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
=====================================
libraries/ghc-internal/src/GHC/Internal/Float.hs
=====================================
@@ -13,6 +13,9 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+-- For init in formatRealFloatAlt
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Internal.Float
=====================================
libraries/ghc-internal/src/GHC/Internal/List.hs
=====================================
@@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a]
tail (_:xs) = xs
tail [] = errorEmptyList "tail"
-{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
-- | \(\mathcal{O}(n)\). Extract the last element of a list, which must be
-- finite and non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs
lastError :: HasCallStack => a
lastError = errorEmptyList "last"
+{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(n)\). Return all the elements of a list except the last one.
-- The list must be non-empty.
--
--- WARNING: This function is partial. Consider using 'unsnoc' instead.
+-- To disable the warning about partiality put
+-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@
+-- at the top of the file. To disable it throughout a package put the same
+-- options into @ghc-options@ section of Cabal file. To disable it in GHCi
+-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@
+-- config file. See also the
+-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides….
--
-- ==== __Examples__
--
@@ -240,6 +254,8 @@ init (x:xs) = init' x xs
where init' _ [] = []
init' y (z:zs) = y : init' z zs
+{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-}
+
-- | \(\mathcal{O}(1)\). Test whether a list is empty.
--
-- >>> null []
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO.hs
=====================================
@@ -825,11 +825,12 @@ output_flags = std_flags
where
-- XXX bits copied from System.FilePath, since that's not available here
- combine a b
- | null b = a
- | null a = b
- | pathSeparator [last a] = a ++ b
- | otherwise = a ++ [pathSeparatorChar] ++ b
+ combine a [] = a
+ combine a b = case unsnoc a of
+ Nothing -> b
+ Just (_, lastA)
+ | pathSeparator [lastA] -> a ++ b
+ | otherwise -> a ++ [pathSeparatorChar] ++ b
tempCounter :: IORef Int
tempCounter = unsafePerformIO $ newIORef 0
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence)
import GHC.Internal.Data.Data hiding (Fixity(..))
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable
+import GHC.Internal.List (unsnoc)
import GHC.Internal.Word
import GHC.Internal.Generics (Generic)
import GHC.Internal.IORef
@@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix
import GHC.Internal.Control.Exception
import GHC.Internal.Num
import GHC.Internal.IO.Unsafe
-import GHC.Internal.List (dropWhile, break, replicate, reverse, last)
+import GHC.Internal.List (dropWhile, break, replicate, reverse)
import GHC.Internal.MVar
import GHC.Internal.IO.Exception
import GHC.Internal.Unicode
@@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type)
import GHC.Internal.ForeignSrcLang
import GHC.Internal.LanguageExtensions
+#ifdef BOOTSTRAP_TH
+#if MIN_VERSION_base(4,19,0)
+import Data.List (unsnoc)
+#else
+import Data.Maybe (maybe)
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+#endif
+#endif
+
-----------------------------------------------------
--
-- The Quasi class
@@ -1296,7 +1307,7 @@ mkName str
-- (i.e. non-empty, starts with capital, all alpha)
is_rev_mod_name rev_mod_str
| (compt, rest) <- break (== '.') rev_mod_str
- , not (null compt), isUpper (last compt), all is_mod_char compt
+ , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt
= case rest of
[] -> True
(_dot : rest') -> is_rev_mod_name rest'
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Posix
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
=====================================
@@ -104,7 +104,7 @@ module System.FilePath.Windows
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust)
-import Data.List(stripPrefix, isSuffixOf)
+import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc)
import System.Environment(getEnv)
@@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
- f xs = case break isSearchPathSeparator xs of
- (pre, [] ) -> g pre
- (pre, _:post) -> g pre ++ f post
-
- g "" = ["." | isPosix]
- g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x]
- g x = [x]
-
+ f xs = let (pre, post) = break isSearchPathSeparator xs
+ in case uncons post of
+ Nothing -> g pre
+ Just (_, t) -> g pre ++ f t
+
+ g x = case uncons x of
+ Nothing -> ["." | isPosix]
+ Just (h, t)
+ | h == '"'
+ , Just{} <- uncons t -- >= 2
+ , isWindows
+ , Just (i, l) <- unsnoc t
+ , l == '"' -> [i]
+ | otherwise -> [x]
-- | Get a list of 'FilePath's in the $PATH variable.
getSearchPath :: IO [FilePath]
@@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH")
-- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred")
-- > splitExtension "file/path.txt/" == ("file/path.txt/","")
splitExtension :: FilePath -> (String, String)
-splitExtension x = case nameDot of
- "" -> (x,"")
- _ -> (dir ++ init nameDot, extSeparator : ext)
- where
- (dir,file) = splitFileName_ x
- (nameDot,ext) = breakEnd isExtSeparator file
+splitExtension x = case unsnoc nameDot of
+ -- Imagine x = "no-dots", then nameDot = ""
+ Nothing -> (x, mempty)
+ Just (initNameDot, _)
+ -- Imagine x = "\\shared.with.dots\no-dots"
+ | isWindows && null (dropDrive nameDot) -> (x, mempty)
+ -- Imagine x = "dir.with.dots/no-dots"
+ | any isPathSeparator ext -> (x, mempty)
+ | otherwise -> (initNameDot, extSeparator : ext)
+ where
+ (nameDot, ext) = breakEnd isExtSeparator x
-- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise.
--
@@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext)
-- > hasTrailingPathSeparator "test" == False
-- > hasTrailingPathSeparator "test/" == True
hasTrailingPathSeparator :: FilePath -> Bool
-hasTrailingPathSeparator "" = False
-hasTrailingPathSeparator x = isPathSeparator (last x)
+hasTrailingPathSeparator = isJust . getTrailingPathSeparator
+getTrailingPathSeparator :: FilePath -> Maybe Char
+getTrailingPathSeparator x = case unsnoc x of
+ Just (_, lastX)
+ | isPathSeparator lastX -> Just lastX
+ _ -> Nothing
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
@@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat
-- > Windows: dropTrailingPathSeparator "\\" == "\\"
-- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x
dropTrailingPathSeparator :: FilePath -> FilePath
-dropTrailingPathSeparator x =
- if hasTrailingPathSeparator x && not (isDrive x)
- then let x' = dropWhileEnd isPathSeparator x
- in if null x' then [last x] else x'
- else x
-
+dropTrailingPathSeparator x = case getTrailingPathSeparator x of
+ Just lastX
+ | not (isDrive x)
+ -> let x' = dropWhileEnd isPathSeparator x
+ in if null x' then [lastX] else x'
+ _ -> x
-- | Get the directory name, move up one level.
--
@@ -863,28 +878,37 @@ makeRelative root path
-- > Posix: normalise "bob/fred/." == "bob/fred/"
-- > Posix: normalise "//home" == "/home"
normalise :: FilePath -> FilePath
-normalise path = result ++ [pathSeparator | addPathSeparator]
- where
- (drv,pth) = splitDrive path
- result = joinDrive' (normaliseDrive drv) (f pth)
+normalise filepath =
+ result <>
+ (if addPathSeparator
+ then [pathSeparator]
+ else mempty)
+ where
+ (drv,pth) = splitDrive filepath
+
+ result = joinDrive' (normaliseDrive drv) (f pth)
- joinDrive' "" "" = "."
- joinDrive' d p = joinDrive d p
+ joinDrive' d p
+ = if null d && null p
+ then "."
+ else joinDrive d p
- addPathSeparator = isDirPath pth
- && not (hasTrailingPathSeparator result)
- && not (isRelativeDrive drv)
+ addPathSeparator = isDirPath pth
+ && not (hasTrailingPathSeparator result)
+ && not (isRelativeDrive drv)
- isDirPath xs = hasTrailingPathSeparator xs
- || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs)
+ isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of
+ Nothing -> False
+ Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs
- f = joinPath . dropDots . propSep . splitDirectories
+ f = joinPath . dropDots . propSep . splitDirectories
- propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs
- | otherwise = x : xs
- propSep [] = []
+ propSep (x:xs)
+ | all isPathSeparator x = [pathSeparator] : xs
+ | otherwise = x : xs
+ propSep [] = []
- dropDots = filter ("." /=)
+ dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive "" = ""
=====================================
testsuite/tests/driver/j-space/jspace.hs
=====================================
@@ -7,7 +7,7 @@ import System.Environment
import GHC.Driver.Env.Types
import GHC.Profiling
import System.Mem
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, unsnoc)
import Control.Monad
import System.Exit
import GHC.Platform
@@ -41,7 +41,9 @@ initGhcM xs = do
requestHeapCensus
performGC
[ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp"
- let (n :: Int) = read (last (words ys))
+ let (n :: Int) = case unsnoc (words ys) of
+ Nothing -> error "input is unexpectedly empty"
+ Just (_, lst) -> read lst
-- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures):
-- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH,
-- and each ModDetails contains 1 (info table) + 8 word-sized fields.
=====================================
testsuite/tests/rts/KeepCafsBase.hs
=====================================
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
module KeepCafsBase (x) where
x :: Int
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..))
import GHC.Parser.Lexer (allocateComments)
import Data.Data hiding ( Fixity )
-import Data.List (sortBy, partition)
+import Data.List (sortBy, partition, unsnoc)
import qualified Data.Map.Strict as Map
import Debug.Trace
@@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []"
ghead _info (h:_) = h
glast :: String -> [a] -> a
-glast info [] = error $ "glast " ++ info ++ " []"
-glast _info h = last h
+glast info xs = case unsnoc xs of
+ Nothing -> error $ "glast " ++ info ++ " []"
+ Just (_, lst) -> lst
gtail :: String -> [a] -> [a]
gtail info [] = error $ "gtail " ++ info ++ " []"
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -8,7 +8,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-}
-- Fine if this comes from make/Hadrian or the pre-built base.
#include <ghcplatform.h>
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
=====================================
@@ -1,6 +1,6 @@
module GHC.Toolchain.CheckArm ( findArmIsa ) where
-import Data.List (isInfixOf)
+import Data.List (isInfixOf, unsnoc)
import Data.Maybe (catMaybes)
import Control.Monad.IO.Class
import System.Process
@@ -76,8 +76,7 @@ findArmIsa cc = do
_ -> throwE $ "unexpected output from test program: " ++ out
lastLine :: String -> String
-lastLine "" = ""
-lastLine s = last $ lines s
+lastLine = maybe "" snd . unsnoc . lines
-- | Raspbian unfortunately makes some extremely questionable packaging
-- decisions, configuring gcc to compile for ARMv6 despite the fact that the
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -755,7 +755,7 @@ ppHtmlIndex
divAlphabet
<< unordList
( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
- [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index
+ [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index
]
++ [merged_name]
)
@@ -772,7 +772,7 @@ ppHtmlIndex
writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
- index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c]
+ index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c]
index :: [(String, Map GHC.Name [(Module, Bool)])]
index = sortBy cmp (Map.toAscList full_index)
=====================================
utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
=====================================
@@ -30,7 +30,7 @@ import Control.Arrow (first)
import Control.Monad
import Data.Char (chr, isAlpha, isSpace, isUpper)
import Data.Functor (($>))
-import Data.List (elemIndex, intercalate, intersperse, unfoldr)
+import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import qualified Data.Set as Set
@@ -870,10 +870,10 @@ codeblock =
DocCodeBlock . parseParagraph . dropSpaces
<$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
where
- dropSpaces xs =
- case splitByNl xs of
- [] -> xs
- ys -> case T.uncons (last ys) of
+ dropSpaces xs = let ys = splitByNl xs in
+ case unsnoc ys of
+ Nothing -> xs
+ Just (_, lastYs) -> case T.uncons lastYs of
Just (' ', _) -> case mapM dropSpace ys of
Nothing -> xs
Just zs -> T.intercalate "\n" zs
=====================================
utils/hpc
=====================================
@@ -1 +1 @@
-Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5
+Subproject commit dd43f7e139d7a4f4908d1e8af35a75939f763ef1
=====================================
utils/hsc2hs
=====================================
@@ -1 +1 @@
-Subproject commit fe3990b9f35000427b016a79330d9f195587cad8
+Subproject commit 2059c961fc28bbfd0cafdbef96d5d21f1d911b53
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfabdcc0be64c68d200e25614ab6391…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dfabdcc0be64c68d200e25614ab6391…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bump-win32-tarballs] rts: Cleanup merge resolution residue in lookupSymbolInDLL_PEi386 and make safe without dependent
by Tamar Christina (＠Phyx) 14 Jul '25
by Tamar Christina (＠Phyx) 14 Jul '25
14 Jul '25
Tamar Christina pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC
Commits:
ab4d6ed6 by Tamar Christina at 2025-07-14T21:39:32+01:00
rts: Cleanup merge resolution residue in lookupSymbolInDLL_PEi386 and make safe without dependent
- - - - -
1 changed file:
- rts/linker/PEi386.c
Changes:
=====================================
rts/linker/PEi386.c
=====================================
@@ -1313,7 +1313,7 @@ lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar*
it generates call *__imp_foo, and __imp_foo here has exactly
the same semantics as in __imp_foo = GetProcAddress(..., "foo")
*/
- if (sym == NULL && strncmp (lbl, "__imp_", 6) == 0) {
+ if (sym == NULL && dependent && strncmp (lbl, "__imp_", 6) == 0) {
sym = GetProcAddress(instance,
lbl + 6);
if (sym != NULL) {
@@ -1329,12 +1329,6 @@ lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar*
}
}
- sym = GetProcAddress(instance, lbl);
- if (sym != NULL) {
- /*debugBelch("found %s in %s\n", lbl,dll_name);*/
- return sym;
- }
-
return NULL;
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab4d6ed63d3f85130f0c0286cdffa1c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab4d6ed63d3f85130f0c0286cdffa1c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: (Applicative docs typo: missing "one")
by Marge Bot (＠marge-bot) 14 Jul '25
by Marge Bot (＠marge-bot) 14 Jul '25
14 Jul '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00
(Applicative docs typo: missing "one")
- - - - -
f707bab4 by Andreas Klebinger at 2025-07-12T14:56:16+01:00
Specialise: Improve specialisation by refactoring interestingDict
This MR addresses #26051, which concerns missed type-class specialisation.
The main payload of the MR is to completely refactor the key function
`interestingDict` in GHC.Core.Opt.Specialise
The main change is that we now also look at the structure of the
dictionary we consider specializing on, rather than only the type.
See the big `Note [Interesting dictionary arguments]`
- - - - -
ca7a9d42 by Simon Peyton Jones at 2025-07-12T14:56:16+01:00
Treat tuple dictionaries uniformly; don't unbox them
See `Note [Do not unbox class dictionaries]` in DmdAnal.hs,
sep (DNB1).
This MR reverses the plan in #23398, which suggested a special case to
unbox tuple dictionaries in worker/wrapper. But:
- This was the cause of a pile of complexity in the specialiser (#26158)
- Even with that complexity, specialision was still bad, very bad
See https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297
And it's entirely unnecessary! Specialision works fine without
unboxing tuple dictionaries.
- - - - -
be7296c9 by Andreas Klebinger at 2025-07-12T14:56:16+01:00
Remove complex special case from the type-class specialiser
There was a pretty tricky special case in Specialise which is no
longer necessary.
* Historical Note [Floating dictionaries out of cases]
* #26158
* #19747 https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297
This MR removes it. Hooray.
- - - - -
e2ef050e by Ben Gamari at 2025-07-14T16:05:03-04:00
configure: bump version to 9.15
- - - - -
25a70dab by Teo Camarasu at 2025-07-14T16:05:04-04:00
rts/nonmovingGC: remove n_free
We remove the nonmovingHeap.n_free variable.
We wanted this to track the length of nonmovingHeap.free.
But this isn't possible to do atomically.
When this isn't accurate we can get a segfault by going past the end of
the list.
Instead, we just count the length of the list when we grab it in
nonmovingPruneFreeSegment.
Resolves #26186
- - - - -
6f309f37 by Wen Kokke at 2025-07-14T16:05:06-04:00
Remove `profile_id` from `traceHeapProfBegin` and `postHeapProfBegin`
- - - - -
57574c3a by Wen Kokke at 2025-07-14T16:05:06-04:00
Remove `profile_id` from `traceHeapProfSampleString` and `postHeapProfSampleString`
- - - - -
a937e595 by Wen Kokke at 2025-07-14T16:05:06-04:00
Remove `profile_id` from `traceHeapProfSampleCostCentre` and `postHeapProfSampleCostCentre`
- - - - -
0e801a05 by Wen Kokke at 2025-07-14T16:05:06-04:00
Make `traceHeapProfBegin` an init event
- - - - -
31 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- configure.ac
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- rts/ProfHeap.c
- rts/RetainerSet.c
- rts/Trace.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
- rts/sm/NonMoving.c
- rts/sm/NonMoving.h
- rts/sm/NonMovingAllocate.c
- rts/sm/Sanity.c
- testsuite/tests/dmdanal/should_compile/T23398.hs
- testsuite/tests/dmdanal/should_compile/T23398.stderr
- + testsuite/tests/perf/should_run/SpecTyFamRun.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.stdout
- + testsuite/tests/perf/should_run/SpecTyFam_Import.hs
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T26051.hs
- + testsuite/tests/simplCore/should_compile/T26051.stderr
- + testsuite/tests/simplCore/should_compile/T26051_Import.hs
- testsuite/tests/simplCore/should_compile/all.T
- utils/haddock/haddock-api/haddock-api.cabal
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f87b4734e374d09362c971567403a2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f87b4734e374d09362c971567403a2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/bump-win32-tarballs] rts/linker/PEi386: Implement IMAGE_REL_AMD64_SECREL
by Ben Gamari (＠bgamari) 14 Jul '25
by Ben Gamari (＠bgamari) 14 Jul '25
14 Jul '25
Ben Gamari pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC
Commits:
2fea7d1f by Ben Gamari at 2025-07-14T14:58:35-04:00
rts/linker/PEi386: Implement IMAGE_REL_AMD64_SECREL
This appears to now be used by libc++ as distributed by msys2.
- - - - -
1 changed file:
- rts/linker/PEi386.c
Changes:
=====================================
rts/linker/PEi386.c
=====================================
@@ -2251,6 +2251,13 @@ ocResolve_PEi386 ( ObjectCode* oc )
*(uint64_t *)pP = S + A;
break;
}
+ case 11: /* IMAGE_REL_AMD64_SECREL (PE constant 11) */
+ {
+ uint64_t offset = S - (uint64_t) section.start;
+ CHECK((uint32_t) offset == offset);
+ *(uint32_t *)pP = offset + A;
+ break;
+ }
case 2: /* R_X86_64_32 (ELF constant 10) - IMAGE_REL_AMD64_ADDR32 (PE constant 2) */
case 3: /* IMAGE_REL_AMD64_ADDR32NB (PE constant 3) */
case 17: /* R_X86_64_32S ELF constant, no PE mapping. See note [ELF constant in PE file] */
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fea7d1f003ab344f2bce10695092dc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fea7d1f003ab344f2bce10695092dc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/ctoi-what] 51 commits: Consider `PromotedDataCon` in `tyConStupidTheta`
by Rodrigo Mesquita (＠alt-romes) 14 Jul '25
by Rodrigo Mesquita (＠alt-romes) 14 Jul '25
14 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/ctoi-what at Glasgow Haskell Compiler / GHC
Commits:
8d33d048 by Berk Özkütük at 2025-07-07T20:42:20-04:00
Consider `PromotedDataCon` in `tyConStupidTheta`
Haddock checks data declarations for the stupid theta so as not to
pretty-print them as empty contexts. Type data declarations end up as
`PromotedDataCon`s by the time Haddock performs this check, causing a
panic. This commit extends `tyConStupidTheta` so that it returns an
empty list for `PromotedDataCon`s. This decision was guided by the fact
that type data declarations never have data type contexts (see (R1) in
Note [Type data declarations]).
Fixes #25739.
- - - - -
a26243fd by Ryan Hendrickson at 2025-07-07T20:43:07-04:00
haddock: Document instances from other packages
When attaching instances to `Interface`s, it isn't enough just to look
for instances in the list of `Interface`s being processed. We also need
to look in the modules on which they depend, including those outside of
this package.
Fixes #25147.
Fixes #26079.
- - - - -
0fb24420 by Rodrigo Mesquita at 2025-07-07T20:43:49-04:00
hadrian: Fallback logic for internal interpreter
When determining whether to build the internal interpreter, the `make`
build system had a fallback case for platforms not in the list of
explicitly-supported operating systems and architectures.
This fallback says we should try to build the internal interpreter if
building dynamic GHC programs (if the architecture is unknown).
Fixes #24098
- - - - -
fe925bd4 by Ben Gamari at 2025-07-07T20:44:30-04:00
users-guide: Reference Wasm FFI section
- - - - -
5856284b by Ben Gamari at 2025-07-07T20:44:30-04:00
users-guide: Fix too-short heading warning
- - - - -
a48dcdf3 by Duncan Coutts at 2025-07-07T20:45:18-04:00
Reorganise documentation for allocate* functions
Consolodate interface information into the .h file, keeping just
implementation details in the .c file.
Use Notes stlye in the .h file and refer to notes from the .c file.
- - - - -
de5b528c by Duncan Coutts at 2025-07-07T20:45:18-04:00
Introduce common utilities for allocating arrays
The intention is to share code among the several places that do this
already.
- - - - -
b321319d by Duncan Coutts at 2025-07-07T20:45:18-04:00
Use new array alloc utils in Heap.c
The CMM primop can now report heap overflow.
- - - - -
1d557ffb by Duncan Coutts at 2025-07-07T20:45:18-04:00
Use new array alloc utils in ThreadLabels.c
Replacing a local utility.
- - - - -
e59a1430 by Duncan Coutts at 2025-07-07T20:45:18-04:00
Use new array alloc utils in Threads.c
Replacing local open coded version.
- - - - -
482df1c9 by Duncan Coutts at 2025-07-07T20:45:18-04:00
Add exitHeapOverflow helper utility
This will be useful with the array alloc functions, since unlike
allocate/allocateMaybeFail, they do not come in two versions. So if it's
not convenient to propagate failure, then one can use this.
- - - - -
4d3ec8f9 by Duncan Coutts at 2025-07-07T20:45:18-04:00
Use new array alloc utils in Weak.c
Also add a cpp macro CCS_SYSTEM_OR_NULL which does what it says. The
benefit of this is that it allows us to referece CCS_SYSTEM even when
we're not in PROFILING mode. That makes abstracting over profiling vs
normal mode a lot easier.
- - - - -
0c4f2fde by Duncan Coutts at 2025-07-07T20:45:18-04:00
Convert the array alloc primops to use the new array alloc utils
- - - - -
a3354ad9 by Duncan Coutts at 2025-07-07T20:45:18-04:00
While we're at it, add one missing 'likely' hint
To a cmm primops that raises an exception, like the others now do.
- - - - -
33b546bd by meooow25 at 2025-07-07T20:46:09-04:00
Keep scanl' strict in the head on rewrite
`scanl'` forces elements to WHNF when the corresponding `(:)`s are
forced. The rewrite rule for `scanl'` missed forcing the first element,
which is fixed here with a `seq`.
- - - - -
8a69196e by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00
debugger/rts: Allow toggling step-in per thread
The RTS global flag `rts_stop_next_breakpoint` globally sets the
interpreter to stop at the immediate next breakpoint.
With this commit, single step mode can additionally be set per thread in
the TSO flag (TSO_STOP_NEXT_BREAKPOINT).
Being able to toggle "stop at next breakpoint" per thread is an
important requirement for implementing "stepping out" of a function in a
multi-threaded context.
And, more generally, having a per-thread flag for single-stepping paves the
way for multi-threaded debugging.
That said, when we want to enable "single step" mode for the whole
interpreted program we still want to stop at the immediate next
breakpoint, whichever thread it belongs to.
That's why we also keep the global `rts_stop_next_breakpoint` flag, with
`rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers.
Preparation for #26042
- - - - -
73d3f864 by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00
docs: Case continuation BCOs
This commit documents a subtle interaction between frames for case BCOs
and their parents frames. Namely, case continuation BCOs may refer to
(non-local) variables that are part of the parent's frame.
The note expanding a bit on these details is called [Case continuation BCOs]
- - - - -
d7aeddcf by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00
debugger: Implement step-out feature
Implements support for stepping-out of a function (aka breaking right after
returning from a function) in the interactive debugger.
It also introduces a GHCi command :stepout to step-out of a function
being debugged in the interpreter. The feature is described as:
Stop at the first breakpoint immediately after returning from the current
function scope.
Known limitations: because a function tail-call does not push a stack
frame, if step-out is used inside of a function that was tail-called,
execution will not be returned to its caller, but rather its caller's
first non-tail caller. On the other hand, it means the debugger
follows the more realistic execution of the program.
In the following example:
.. code-block:: none
f = do
a
b <--- (1) set breakpoint then step in here
c
b = do
...
d <--- (2) step-into this tail call
d = do
...
something <--- (3) step-out here
...
Stepping-out will stop execution at the `c` invokation in `f`, rather than
stopping at `b`.
The key idea is simple: When step-out is enabled, traverse the runtime
stack until a continuation BCO is found -- and enable the breakpoint
heading that BCO explicitly using its tick-index.
The details are specified in `Note [Debugger: Step-out]` in `rts/Interpreter.c`.
Since PUSH_ALTS BCOs (representing case continuations) were never headed
by a breakpoint (unlike the case alternatives they push), we introduced
the BRK_ALTS instruction to allow the debugger to set a case
continuation to stop at the breakpoint heading the alternative that is
taken. This is further described in `Note [Debugger: BRK_ALTS]`.
Fixes #26042
- - - - -
5d9adf51 by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00
debugger: Filter step-out stops by SrcSpan
To implement step-out, the RTS looks for the first continuation frame on
the stack and explicitly enables its entry breakpoint. However, some
continuations will be contained in the function from which step-out was
initiated (trivial example is a case expression).
Similarly to steplocal, we will filter the breakpoints at which the RTS
yields to the debugger based on the SrcSpan. When doing step-out, only
stop if the breakpoint is /not/ contained in the function from which we
initiated it.
This is especially relevant in monadic statements such as IO which is
compiled to a long chain of case expressions.
See Note [Debugger: Filtering step-out stops]
- - - - -
7677adcc by Cheng Shao at 2025-07-08T07:40:29-04:00
compiler: make ModBreaks serializable
- - - - -
14f67c6d by Rodrigo Mesquita at 2025-07-08T07:40:29-04:00
refactor: "Inspecting the session" moved from GHC
Moved utilities for inspecting the session from the GHC module to
GHC.Driver.Session.Inspect
Purely a clean up
- - - - -
9d3f484a by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
cleanup: Pass the HUG to readModBreaks, not HscEnv
A minor cleanup. The associated history and setupBreakpoint functions
are changed accordingly.
- - - - -
b595f713 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
cleanup: Move readModBreaks to GHC.Runtime.Interpreter
With some small docs changes
- - - - -
d223227a by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
cleanup: Move interpreterProfiled to Interp.Types
Moves interpreterProfiled and interpreterDynamic to
GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter.
- - - - -
7fdd0a3d by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
cleanup: Don't import GHC in Debugger.Breakpoints
Remove the top-level
import GHC
from GHC.Runtime.Debugger.Breakpoints
This makes the module dependencies more granular and cleans up the
qualified imports from the code.
- - - - -
5e4da31b by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
refactor: Use BreakpointId in Core and Ifaces
- - - - -
741ac3a8 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
stg2bc: Derive BcM via ReaderT StateT
A small refactor that simplifies GHC.StgToByteCode by deriving-via the
Monad instances for BcM. This is done along the lines of previous
similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465.
- - - - -
0414fcc9 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
refact: Split InternalModBreaks out of ModBreaks
There are currently two competing ways of referring to a Breakpoint:
1. Using the Tick module + Tick index
2. Using the Info module + Info index
1. The Tick index is allocated during desugaring in `mkModBreaks`. It is
used to refer to a breakpoint associated to a Core Tick. For a given
Tick module, there are N Ticks indexed by Tick index.
2. The Info index is allocated during code generation (in StgToByteCode)
and uniquely identifies the breakpoints at runtime (and is indeed used
to determine which breakpoint was hit at runtime).
Why we need both is described by Note [Breakpoint identifiers].
For every info index we used to keep a `CgBreakInfo`, a datatype containing
information relevant to ByteCode Generation, in `ModBreaks`.
This commit splits out the `IntMap CgBreakInfo` out of `ModBreaks` into
a new datatype `InternalModBreaks`.
- The purpose is to separate the `ModBreaks` datatype, which stores
data associated from tick-level information which is fixed after
desugaring, from the unrelated `IntMap CgBreakInfo` information
accumulated during bytecode generation.
- We move `ModBreaks` to GHC.HsToCore.Breakpoints
The new `InternalModBreaks` simply combines the `IntMap CgBreakInfo`
with `ModBreaks`. After code generation we construct an
`InternalModBreaks` with the `CgBreakInfo`s we accumulated and the
existing `ModBreaks` and store that in the compiled BCO in `bc_breaks`.
- Note that we previously only updated the `modBreaks_breakInfo`
field of `ModBreaks` at this exact location, and then stored the
updated `ModBreaks` in the same `bc_breaks`.
- We put this new datatype in GHC.ByteCode.Breakpoints
The rest of the pipeline for which CgBreakInfo is relevant is
accordingly updated to also use `InternalModBreaks`
- - - - -
2a097955 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
cleanup: Use BreakpointIds in bytecode gen
Small clean up to use BreakpointId and InternalBreakpointId more
uniformly in bytecode generation rather than using Module + Ix pairs
- - - - -
0515cc2f by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00
ghci: Allocate BreakArrays at link time only
Previously, a BreakArray would be allocated with a slot for every tick
in a module at `mkModBreaks`, in HsToCore. However, this approach has
a few downsides:
- It interleaves interpreter behaviour (allocating arrays for
breakpoints) within the desugarer
- It is inflexible in the sense it is impossible for the bytecode
generator to add "internal" breakpoints that can be triggered at
runtime, because those wouldn't have a source tick. (This is relevant
for our intended implementation plan of step-out in #26042)
- It ties the BreakArray indices to the *tick* indexes, while at runtime
we would rather just have the *info* indexes (currently we have both
because BreakArrays are indexed by the *tick* one).
Paving the way for #26042 and #26064, this commit moves the allocation
of BreakArrays to bytecode-loading time -- akin to what is done for CCS
arrays.
Since a BreakArray is allocated only when bytecode is linked, if a
breakpoint is set (e.g. `:break 10`) before the bytecode is linked,
there will exist no BreakArray to trigger the breakpoint in.
Therefore, the function to allocate break arrays (`allocateBreakArrays`)
is exposed and also used in GHC.Runtime.Eval to allocate a break array
when a breakpoint is set, if it doesn't exist yet (in the linker env).
- - - - -
8016561f by Simon Peyton Jones at 2025-07-08T07:41:13-04:00
Add a test for T26176
- - - - -
454cd682 by Simon Peyton Jones at 2025-07-08T07:41:13-04:00
Add test for #14010
This test started to work in GHC 9.6 and has worked since.
This MR just adds a regression test
- - - - -
ea2c6673 by Teo Camarasu at 2025-07-08T13:24:43-04:00
Implement user-defined allocation limit handlers
Allocation Limits allow killing a thread if they allocate more than a
user-specified limit.
We extend this feature to allow more versatile behaviour.
- We allow not killing the thread if the limit is exceeded.
- We allow setting a custom handler to be called when the limit is exceeded.
User-specified allocation limit handlers run in a fresh thread and are passed
the ThreadId of the thread that exceeded its limit.
We introduce utility functions for getting and setting the allocation
limits of other threads, so that users can reset the limit of a thread
from a handler. Both of these are somewhat coarse-grained as we are
unaware of the allocations in the current nursery chunk.
We provide several examples of usages in testsuite/tests/rts/T22859.hs
Resolves #22859
- - - - -
03e047f9 by Simon Hengel at 2025-07-08T13:25:25-04:00
Fix typo in using.rst
- - - - -
67957854 by Ben Gamari at 2025-07-09T09:44:44-04:00
compiler: Import AnnotationWrapper from ghc-internal
Since `GHC.Desugar` exported from `base` has been deprecated.
- - - - -
813d99d6 by Ben Gamari at 2025-07-09T09:44:44-04:00
ghc-compact: Eliminate dependency on ghc-prim
- - - - -
0ec952a1 by Ben Gamari at 2025-07-09T09:44:44-04:00
ghc-heap: Eliminate dependency on ghc-prim
- - - - -
480074c3 by Ben Gamari at 2025-07-09T09:44:44-04:00
ghc-heap: Drop redundant import
- - - - -
03455829 by Ben Gamari at 2025-07-09T09:44:45-04:00
ghc-prim: Bump version to 0.13.1
There are no interface changes from 0.13.0 but the implementation now
lives in `ghc-internal`.
- - - - -
d315345a by Ben Gamari at 2025-07-09T09:44:45-04:00
template-haskell: Bump version number to 2.24.0.0
Bumps exceptions submodule.
- - - - -
004c800e by Ben Gamari at 2025-07-09T09:44:45-04:00
Bump GHC version number to 9.14
- - - - -
eb1a3816 by Ben Gamari at 2025-07-09T09:44:45-04:00
Bump parsec to 3.1.18.0
Bumps parsec submodule.
- - - - -
86f83296 by Ben Gamari at 2025-07-09T09:44:45-04:00
unix: Bump to 2.8.7.0
Bumps unix submodule.
- - - - -
89e13998 by Ben Gamari at 2025-07-09T09:44:45-04:00
binary: Bump to 0.8.9.3
Bumps binary submodule.
- - - - -
55fff191 by Ben Gamari at 2025-07-09T09:44:45-04:00
Win32: Bump to 2.14.2.0
Bumps Win32 submodule.
- - - - -
7dafa40c by Ben Gamari at 2025-07-09T09:44:45-04:00
base: Bump version to 4.22.0
Bumps various submodules.
- - - - -
ef03d8b8 by Rodrigo Mesquita at 2025-07-09T09:45:28-04:00
base: Export displayExceptionWithInfo
This function should be exposed from base following CLC#285
Approved change in CLC#344
Fixes #26058
- - - - -
01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00
Fix documentation for HEAP_PROF_SAMPLE_STRING
- - - - -
ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00
Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE
- - - - -
2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00
(Applicative docs typo: missing "one")
- - - - -
71f29b61 by Rodrigo Mesquita at 2025-07-14T19:54:13+01:00
ctoi what
- - - - -
184 changed files:
- compiler/GHC.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- + compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Map/Expr.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Config.hs
- + compiler/GHC/Driver/Session/Inspect.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Eval/Types.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- compiler/GHC/Stg/BcPrep.hs
- compiler/GHC/Stg/FVs.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/Tc/Gen/Splice.hs
- − compiler/GHC/Types/Breakpoint.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Unit/Module/ModGuts.hs
- compiler/ghc.cabal.in
- configure.ac
- docs/users_guide/eventlog-formats.rst
- docs/users_guide/exts/doandifthenelse.rst
- docs/users_guide/exts/ffi.rst
- docs/users_guide/ghci.rst
- docs/users_guide/using.rst
- ghc/GHCi/UI.hs
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Packages.hs
- hadrian/src/Settings/Program.hs
- libraries/Win32
- libraries/array
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- libraries/base/src/Control/Exception.hs
- libraries/binary
- libraries/deepseq
- libraries/directory
- libraries/exceptions
- libraries/filepath
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-compact/GHC/Compact.hs
- libraries/ghc-compact/GHC/Compact/Serialized.hs
- libraries/ghc-compact/ghc-compact.cabal
- libraries/ghc-experimental/ghc-experimental.cabal.in
- + libraries/ghc-experimental/src/System/Mem/Experimental.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc
- libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/tests/parse_tso_flags.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-prim/changelog.md
- libraries/ghc-prim/ghc-prim.cabal
- + libraries/ghci/GHCi/Debugger.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/hpc
- libraries/os-string
- libraries/parsec
- libraries/process
- libraries/semaphore-compat
- libraries/stm
- libraries/template-haskell/template-haskell.cabal.in
- libraries/terminfo
- libraries/text
- libraries/unix
- + rts/AllocArray.c
- + rts/AllocArray.h
- rts/Disassembler.c
- rts/Heap.c
- rts/Interpreter.c
- rts/Interpreter.h
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/RtsUtils.c
- rts/Schedule.c
- rts/StgMiscClosures.cmm
- rts/ThreadLabels.c
- rts/Threads.c
- rts/Weak.c
- rts/external-symbols.list.in
- rts/include/Rts.h
- rts/include/rts/Bytecodes.h
- rts/include/rts/Constants.h
- rts/include/rts/prof/CCS.h
- rts/include/rts/storage/Closures.h
- rts/include/rts/storage/GC.h
- rts/include/rts/storage/Heap.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- rts/rts.cabal
- rts/sm/Storage.c
- testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042b.hs
- + testsuite/tests/ghci.debugger/scripts/T26042b.script
- + testsuite/tests/ghci.debugger/scripts/T26042b.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042c.hs
- + testsuite/tests/ghci.debugger/scripts/T26042c.script
- + testsuite/tests/ghci.debugger/scripts/T26042c.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042d.hs
- + testsuite/tests/ghci.debugger/scripts/T26042d.script
- + testsuite/tests/ghci.debugger/scripts/T26042d.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042e.hs
- + testsuite/tests/ghci.debugger/scripts/T26042e.script
- + testsuite/tests/ghci.debugger/scripts/T26042e.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042f.hs
- + testsuite/tests/ghci.debugger/scripts/T26042f.script
- + testsuite/tests/ghci.debugger/scripts/T26042f1.stderr
- + testsuite/tests/ghci.debugger/scripts/T26042f1.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042f2.stdout
- + testsuite/tests/ghci.debugger/scripts/T26042g.hs
- + testsuite/tests/ghci.debugger/scripts/T26042g.script
- + testsuite/tests/ghci.debugger/scripts/T26042g.stdout
- testsuite/tests/ghci.debugger/scripts/all.T
- + testsuite/tests/indexed-types/should_fail/T26176.hs
- + testsuite/tests/indexed-types/should_fail/T26176.stderr
- testsuite/tests/indexed-types/should_fail/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- + testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/T22859.stderr
- testsuite/tests/rts/all.T
- + testsuite/tests/typecheck/should_compile/T14010.hs
- testsuite/tests/typecheck/should_compile/all.T
- utils/haddock/CHANGES.md
- utils/haddock/haddock-api/haddock-api.cabal
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- utils/haddock/haddock-library/haddock-library.cabal
- utils/haddock/haddock-test/haddock-test.cabal
- utils/haddock/haddock-test/src/Test/Haddock/Config.hs
- utils/haddock/haddock.cabal
- utils/haddock/html-test/ref/Bug1004.html
- + utils/haddock/html-test/ref/Bug25739.html
- + utils/haddock/html-test/src/Bug25739.hs
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d30059ded04b7324fc176d85c83e9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d30059ded04b7324fc176d85c83e9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
14 Jul '25
Rodrigo Mesquita pushed new branch wip/romes/ctoi-what at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/romes/ctoi-what
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Ben Gamari pushed new branch wip/ctoi-refactor at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ctoi-refactor
You're receiving this email because of your account on gitlab.haskell.org.
1
0